Theory Finite_Field
section ‹Finite Rings and Fields›
text ‹We start by establishing some preliminary results about finite rings and finite fields›
subsection ‹Finite Rings›
theory Finite_Field
imports
"HOL-Computational_Algebra.Primes"
"HOL-Number_Theory.Residues"
"HOL-Library.Cardinality"
Subresultants.Binary_Exponentiation
Polynomial_Interpolation.Ring_Hom_Poly
begin
typedef ('a::finite) mod_ring = "{0..<int CARD('a)}" by auto
setup_lifting type_definition_mod_ring
lemma CARD_mod_ring[simp]: "CARD('a mod_ring) = CARD('a::finite)"
proof -
have "card {y. ∃x∈{0..<int CARD('a)}. (y::'a mod_ring) = Abs_mod_ring x} = card {0..<int CARD('a)}"
proof (rule bij_betw_same_card)
have "inj_on Rep_mod_ring {y. ∃x∈{0..<int CARD('a)}. y = Abs_mod_ring x}"
by (meson Rep_mod_ring_inject inj_onI)
moreover have "Rep_mod_ring ` {y. ∃x∈{0..<int CARD('a)}. (y::'a mod_ring) = Abs_mod_ring x} = {0..<int CARD('a)}"
proof (auto simp add: image_def Rep_mod_ring_inject)
fix xb show "0 ≤ Rep_mod_ring (Abs_mod_ring xb)"
using Rep_mod_ring atLeastLessThan_iff by blast
assume xb1: "0 ≤ xb" and xb2: "xb < int CARD('a)"
thus " Rep_mod_ring (Abs_mod_ring xb) < int CARD('a)"
by (metis Abs_mod_ring_inverse Rep_mod_ring atLeastLessThan_iff le_less_trans linear)
have xb: "xb ∈ {0..<int CARD('a)}" using xb1 xb2 by simp
show "∃xa::'a mod_ring. (∃x∈{0..<int CARD('a)}. xa = Abs_mod_ring x) ∧ xb = Rep_mod_ring xa"
by (rule exI[of _ "Abs_mod_ring xb"], auto simp add: xb1 xb2, rule Abs_mod_ring_inverse[OF xb, symmetric])
qed
ultimately show "bij_betw Rep_mod_ring
{y. ∃x∈{0..<int CARD('a)}. (y::'a mod_ring) = Abs_mod_ring x}
{0..<int CARD('a)}"
by (simp add: bij_betw_def)
qed
thus ?thesis
unfolding type_definition.univ[OF type_definition_mod_ring]
unfolding image_def by auto
qed
instance mod_ring :: (finite) finite
proof (intro_classes)
show "finite (UNIV::'a mod_ring set)"
unfolding type_definition.univ[OF type_definition_mod_ring]
using finite by simp
qed
instantiation mod_ring :: (finite) equal
begin
lift_definition equal_mod_ring :: "'a mod_ring ⇒ 'a mod_ring ⇒ bool" is "(=)" .
instance by (intro_classes, transfer, auto)
end
instantiation mod_ring :: (finite) comm_ring
begin
lift_definition plus_mod_ring :: "'a mod_ring ⇒ 'a mod_ring ⇒ 'a mod_ring" is
"λ x y. (x + y) mod int (CARD('a))" by simp
lift_definition uminus_mod_ring :: "'a mod_ring ⇒ 'a mod_ring" is
"λ x. if x = 0 then 0 else int (CARD('a)) - x" by simp
lift_definition minus_mod_ring :: "'a mod_ring ⇒ 'a mod_ring ⇒ 'a mod_ring" is
"λ x y. (x - y) mod int (CARD('a))" by simp
lift_definition times_mod_ring :: "'a mod_ring ⇒ 'a mod_ring ⇒ 'a mod_ring" is
"λ x y. (x * y) mod int (CARD('a))" by simp
lift_definition zero_mod_ring :: "'a mod_ring" is 0 by simp
instance
by standard
(transfer; auto simp add: mod_simps algebra_simps intro: mod_diff_cong)+
end
lift_definition to_int_mod_ring :: "'a::finite mod_ring ⇒ int" is "λ x. x" .
lift_definition of_int_mod_ring :: "int ⇒ 'a::finite mod_ring" is
"λ x. x mod int (CARD('a))" by simp
interpretation to_int_mod_ring_hom: inj_zero_hom to_int_mod_ring
by (unfold_locales; transfer, auto)
lemma int_nat_card[simp]: "int (nat CARD('a::finite)) = CARD('a)" by auto
interpretation of_int_mod_ring_hom: zero_hom of_int_mod_ring
by (unfold_locales, transfer, auto)
lemma of_int_mod_ring_to_int_mod_ring[simp]:
"of_int_mod_ring (to_int_mod_ring x) = x" by (transfer, auto)
lemma to_int_mod_ring_of_int_mod_ring[simp]: "0 ≤ x ⟹ x < int CARD('a :: finite) ⟹
to_int_mod_ring (of_int_mod_ring x :: 'a mod_ring) = x"
by (transfer, auto)
lemma range_to_int_mod_ring:
"range (to_int_mod_ring :: ('a :: finite mod_ring ⇒ int)) = {0 ..< CARD('a)}"
apply (intro equalityI subsetI)
apply (elim rangeE, transfer, force)
by (auto intro!: range_eqI to_int_mod_ring_of_int_mod_ring[symmetric])
subsection ‹Nontrivial Finite Rings›
class nontriv = assumes nontriv: "CARD('a) > 1"
subclass(in nontriv) finite by(intro_classes,insert nontriv,auto intro:card_ge_0_finite)
instantiation mod_ring :: (nontriv) comm_ring_1
begin
lift_definition one_mod_ring :: "'a mod_ring" is 1 using nontriv[where ?'a='a] by auto
instance by (intro_classes; transfer, simp)
end
interpretation to_int_mod_ring_hom: inj_one_hom to_int_mod_ring
by (unfold_locales, transfer, simp)
lemma of_nat_of_int_mod_ring [code_unfold]:
"of_nat = of_int_mod_ring o int"
proof (rule ext, unfold o_def)
show "of_nat n = of_int_mod_ring (int n)" for n
proof (induct n)
case (Suc n)
show ?case
by (simp only: of_nat_Suc Suc, transfer) (simp add: mod_simps)
qed simp
qed
lemma of_nat_card_eq_0[simp]: "(of_nat (CARD('a::nontriv)) :: 'a mod_ring) = 0"
by (unfold of_nat_of_int_mod_ring, transfer, auto)
lemma of_int_of_int_mod_ring[code_unfold]: "of_int = of_int_mod_ring"
proof (rule ext)
fix x :: int
obtain n1 n2 where x: "x = int n1 - int n2" by (rule int_diff_cases)
show "of_int x = of_int_mod_ring x"
unfolding x of_int_diff of_int_of_nat_eq of_nat_of_int_mod_ring o_def
by (transfer, simp add: mod_diff_right_eq mod_diff_left_eq)
qed
unbundle lifting_syntax
lemma pcr_mod_ring_to_int_mod_ring: "pcr_mod_ring = (λx y. x = to_int_mod_ring y)"
unfolding mod_ring.pcr_cr_eq unfolding cr_mod_ring_def to_int_mod_ring.rep_eq ..
lemma [transfer_rule]:
"((=) ===> pcr_mod_ring) (λ x. int x mod int (CARD('a :: nontriv))) (of_nat :: nat ⇒ 'a mod_ring)"
by (intro rel_funI, unfold pcr_mod_ring_to_int_mod_ring of_nat_of_int_mod_ring, transfer, auto)
lemma [transfer_rule]:
"((=) ===> pcr_mod_ring) (λ x. x mod int (CARD('a :: nontriv))) (of_int :: int ⇒ 'a mod_ring)"
by (intro rel_funI, unfold pcr_mod_ring_to_int_mod_ring of_int_of_int_mod_ring, transfer, auto)
lemma one_mod_card [simp]: "1 mod CARD('a::nontriv) = 1"
using mod_less nontriv by blast
lemma Suc_0_mod_card [simp]: "Suc 0 mod CARD('a::nontriv) = 1"
using one_mod_card by simp
lemma one_mod_card_int [simp]: "1 mod int CARD('a::nontriv) = 1"
proof -
from nontriv [where ?'a = 'a] have "int (1 mod CARD('a::nontriv)) = 1"
by simp
then show ?thesis
using of_nat_mod [of 1 "CARD('a)", where ?'a = int] by simp
qed
lemma pow_mod_ring_transfer[transfer_rule]:
"(pcr_mod_ring ===> (=) ===> pcr_mod_ring)
(λa::int. λn. a^n mod CARD('a::nontriv)) ((^)::'a mod_ring ⇒ nat ⇒ 'a mod_ring)"
unfolding pcr_mod_ring_to_int_mod_ring
proof (intro rel_funI,simp)
fix x::"'a mod_ring" and n
show "to_int_mod_ring x ^ n mod int CARD('a) = to_int_mod_ring (x ^ n)"
proof (induct n)
case 0
thus ?case by auto
next
case (Suc n)
have "to_int_mod_ring (x ^ Suc n) = to_int_mod_ring (x * x ^ n)" by auto
also have "... = to_int_mod_ring x * to_int_mod_ring (x ^ n) mod CARD('a)"
unfolding to_int_mod_ring_def using times_mod_ring.rep_eq by auto
also have "... = to_int_mod_ring x * (to_int_mod_ring x ^ n mod CARD('a)) mod CARD('a)"
using Suc.hyps by auto
also have "... = to_int_mod_ring x ^ Suc n mod int CARD('a)"
by (simp add: mod_simps)
finally show ?case ..
qed
qed
lemma dvd_mod_ring_transfer[transfer_rule]:
"((pcr_mod_ring :: int ⇒ 'a :: nontriv mod_ring ⇒ bool) ===>
(pcr_mod_ring :: int ⇒ 'a mod_ring ⇒ bool) ===> (=))
(λ i j. ∃k ∈ {0..<int CARD('a)}. j = i * k mod int CARD('a)) (dvd)"
proof (unfold pcr_mod_ring_to_int_mod_ring, intro rel_funI iffI)
fix x y :: "'a mod_ring" and i j
assume i: "i = to_int_mod_ring x" and j: "j = to_int_mod_ring y"
{ assume "x dvd y"
then obtain z where "y = x * z" by (elim dvdE, auto)
then have "j = i * to_int_mod_ring z mod CARD('a)" by (unfold i j, transfer)
with range_to_int_mod_ring
show "∃k ∈ {0..<int CARD('a)}. j = i * k mod CARD('a)" by auto
}
assume "∃k ∈ {0..<int CARD('a)}. j = i * k mod CARD('a)"
then obtain k where k: "k ∈ {0..<int CARD('a)}" and dvd: "j = i * k mod CARD('a)" by auto
from k have "to_int_mod_ring (of_int k :: 'a mod_ring) = k" by (transfer, auto)
also from dvd have "j = i * ... mod CARD('a)" by auto
finally have "y = x * (of_int k :: 'a mod_ring)" unfolding i j using k by (transfer, auto)
then show "x dvd y" by auto
qed
lemma Rep_mod_ring_mod[simp]: "Rep_mod_ring (a :: 'a :: nontriv mod_ring) mod CARD('a) = Rep_mod_ring a"
using Rep_mod_ring[where 'a = 'a] by auto
subsection ‹Finite Fields›
text ‹When the domain is prime, the ring becomes a field›
class prime_card = assumes prime_card: "prime (CARD('a))"
begin
lemma prime_card_int: "prime (int (CARD('a)))" using prime_card by auto
subclass nontriv using prime_card prime_gt_1_nat by (intro_classes,auto)
end
instantiation mod_ring :: (prime_card) field
begin
definition inverse_mod_ring :: "'a mod_ring ⇒ 'a mod_ring" where
"inverse_mod_ring x = (if x = 0 then 0 else x ^ (nat (CARD('a) - 2)))"
definition divide_mod_ring :: "'a mod_ring ⇒ 'a mod_ring ⇒ 'a mod_ring" where
"divide_mod_ring x y = x * ((λc. if c = 0 then 0 else c ^ (nat (CARD('a) - 2))) y)"
instance
proof
fix a b c::"'a mod_ring"
show "inverse 0 = (0::'a mod_ring)" by (simp add: inverse_mod_ring_def)
show "a div b = a * inverse b"
unfolding inverse_mod_ring_def by (transfer', simp add: divide_mod_ring_def)
show "a ≠ 0 ⟹ inverse a * a = 1"
proof (unfold inverse_mod_ring_def, transfer)
let ?p="CARD('a)"
fix x
assume x: "x ∈ {0..<int CARD('a)}" and x0: "x ≠ 0"
have p0': "0≤?p" by auto
have "¬ ?p dvd x"
using x x0 zdvd_imp_le by fastforce
then have "¬ CARD('a) dvd nat ¦x¦"
by simp
with x have "¬ CARD('a) dvd nat x"
by simp
have rw: "x ^ nat (int (?p - 2)) * x = x ^ nat (?p - 1)"
proof -
have p2: "0 ≤ int (?p-2)" using x by simp
have card_rw: "(CARD('a) - Suc 0) = nat (1 + int (CARD('a) - 2))"
using nat_eq_iff x x0 by auto
have "x ^ nat (?p - 2)*x = x ^ (Suc (nat (?p - 2)))" by simp
also have "... = x ^ (nat (?p - 1))"
using Suc_nat_eq_nat_zadd1[OF p2] card_rw by auto
finally show ?thesis .
qed
have "[int (nat x ^ (CARD('a) - 1)) = int 1] (mod CARD('a))"
using fermat_theorem [OF prime_card ‹¬ CARD('a) dvd nat x›]
by (simp only: cong_def cong_def of_nat_mod [symmetric])
then have *: "[x ^ (CARD('a) - 1) = 1] (mod CARD('a))"
using x by auto
have "x ^ (CARD('a) - 2) mod CARD('a) * x mod CARD('a)
= (x ^ nat (CARD('a) - 2) * x) mod CARD('a)" by (simp add: mod_simps)
also have "... = (x ^ nat (?p - 1) mod ?p)" unfolding rw by simp
also have "... = (x ^ (nat ?p - 1) mod ?p)" using p0' by (simp add: nat_diff_distrib')
also have "... = 1"
using * by (simp add: cong_def)
finally show "(if x = 0 then 0 else x ^ nat (int (CARD('a) - 2)) mod CARD('a)) * x mod CARD('a) = 1"
using x0 by auto
qed
qed
end
instantiation mod_ring :: (prime_card) "{normalization_euclidean_semiring, euclidean_ring}"
begin
definition modulo_mod_ring :: "'a mod_ring ⇒ 'a mod_ring ⇒ 'a mod_ring" where "modulo_mod_ring x y = (if y = 0 then x else 0)"
definition normalize_mod_ring :: "'a mod_ring ⇒ 'a mod_ring" where "normalize_mod_ring x = (if x = 0 then 0 else 1)"
definition unit_factor_mod_ring :: "'a mod_ring ⇒ 'a mod_ring" where "unit_factor_mod_ring x = x"
definition euclidean_size_mod_ring :: "'a mod_ring ⇒ nat" where "euclidean_size_mod_ring x = (if x = 0 then 0 else 1)"
instance
proof (intro_classes)
fix a :: "'a mod_ring" show "a ≠ 0 ⟹ unit_factor a dvd 1"
unfolding dvd_def unit_factor_mod_ring_def by (intro exI[of _ "inverse a"], auto)
qed (auto simp: normalize_mod_ring_def unit_factor_mod_ring_def modulo_mod_ring_def
euclidean_size_mod_ring_def field_simps)
end
instantiation mod_ring :: (prime_card) euclidean_ring_gcd
begin
definition gcd_mod_ring :: "'a mod_ring ⇒ 'a mod_ring ⇒ 'a mod_ring" where "gcd_mod_ring = Euclidean_Algorithm.gcd"
definition lcm_mod_ring :: "'a mod_ring ⇒ 'a mod_ring ⇒ 'a mod_ring" where "lcm_mod_ring = Euclidean_Algorithm.lcm"
definition Gcd_mod_ring :: "'a mod_ring set ⇒ 'a mod_ring" where "Gcd_mod_ring = Euclidean_Algorithm.Gcd"
definition Lcm_mod_ring :: "'a mod_ring set ⇒ 'a mod_ring" where "Lcm_mod_ring = Euclidean_Algorithm.Lcm"
instance by (intro_classes, auto simp: gcd_mod_ring_def lcm_mod_ring_def Gcd_mod_ring_def Lcm_mod_ring_def)
end
instantiation mod_ring :: (prime_card) unique_euclidean_ring
begin
definition [simp]: "division_segment_mod_ring (x :: 'a mod_ring) = (1 :: 'a mod_ring)"
instance by intro_classes (auto simp: euclidean_size_mod_ring_def split: if_splits)
end
instance mod_ring :: (prime_card) field_gcd
by intro_classes auto
lemma surj_of_nat_mod_ring: "∃ i. i < CARD('a :: prime_card) ∧ (x :: 'a mod_ring) = of_nat i"
by (rule exI[of _ "nat (to_int_mod_ring x)"], unfold of_nat_of_int_mod_ring o_def,
subst nat_0_le, transfer, simp, simp, transfer, auto)
lemma of_nat_0_mod_ring_dvd: assumes x: "of_nat x = (0 :: 'a ::prime_card mod_ring)"
shows "CARD('a) dvd x"
proof -
let ?x = "of_nat x :: int"
from x have "of_int_mod_ring ?x = (0 :: 'a mod_ring)" by (fold of_int_of_int_mod_ring, simp)
hence "?x mod CARD('a) = 0" by (transfer, auto)
hence "x mod CARD('a) = 0" by presburger
thus ?thesis unfolding mod_eq_0_iff_dvd .
qed
end
Theory Arithmetic_Record_Based
section ‹Arithmetics via Records›
text ‹We create a locale for rings and fields based on a record
that includes all the necessary operations.›
theory Arithmetic_Record_Based
imports
"HOL-Library.More_List"
"HOL-Computational_Algebra.Euclidean_Algorithm"
begin
datatype 'a arith_ops_record = Arith_Ops_Record
(zero : 'a)
(one : 'a)
(plus : "'a ⇒ 'a ⇒ 'a")
(times : "'a ⇒ 'a ⇒ 'a")
(minus : "'a ⇒ 'a ⇒ 'a")
(uminus : "'a ⇒ 'a")
(divide : "'a ⇒ 'a ⇒ 'a")
(inverse : "'a ⇒ 'a")
("modulo" : "'a ⇒ 'a ⇒ 'a")
(normalize : "'a ⇒ 'a")
(unit_factor : "'a ⇒ 'a")
(of_int : "int ⇒ 'a")
(to_int : "'a ⇒ int")
(DP : "'a ⇒ bool")
hide_const (open)
zero
one
plus
times
minus
uminus
divide
inverse
modulo
normalize
unit_factor
of_int
to_int
DP
fun listprod_i :: "'i arith_ops_record ⇒ 'i list ⇒ 'i" where
"listprod_i ops (x # xs) = arith_ops_record.times ops x (listprod_i ops xs)"
| "listprod_i ops [] = arith_ops_record.one ops"
locale arith_ops = fixes ops :: "'i arith_ops_record" (structure)
begin
abbreviation (input) zero where "zero ≡ arith_ops_record.zero ops"
abbreviation (input) one where "one ≡ arith_ops_record.one ops"
abbreviation (input) plus where "plus ≡ arith_ops_record.plus ops"
abbreviation (input) times where "times ≡ arith_ops_record.times ops"
abbreviation (input) minus where "minus ≡ arith_ops_record.minus ops"
abbreviation (input) uminus where "uminus ≡ arith_ops_record.uminus ops"
abbreviation (input) divide where "divide ≡ arith_ops_record.divide ops"
abbreviation (input) inverse where "inverse ≡ arith_ops_record.inverse ops"
abbreviation (input) modulo where "modulo ≡ arith_ops_record.modulo ops"
abbreviation (input) normalize where "normalize ≡ arith_ops_record.normalize ops"
abbreviation (input) unit_factor where "unit_factor ≡ arith_ops_record.unit_factor ops"
abbreviation (input) DP where "DP ≡ arith_ops_record.DP ops"
partial_function (tailrec) gcd_eucl_i :: "'i ⇒ 'i ⇒ 'i" where
"gcd_eucl_i a b = (if b = zero
then normalize a else gcd_eucl_i b (modulo a b))"
partial_function (tailrec) euclid_ext_aux_i :: "'i ⇒ 'i ⇒ 'i ⇒ 'i ⇒ 'i ⇒ 'i ⇒ ('i × 'i) × 'i" where
"euclid_ext_aux_i s' s t' t r' r = (
if r = zero then let c = divide one (unit_factor r') in ((times s' c, times t' c), normalize r')
else let q = divide r' r
in euclid_ext_aux_i s (minus s' (times q s)) t (minus t' (times q t)) r (modulo r' r))"
abbreviation (input) euclid_ext_i :: "'i ⇒ 'i ⇒ ('i × 'i) × 'i" where
"euclid_ext_i ≡ euclid_ext_aux_i one zero zero one"
end
declare arith_ops.gcd_eucl_i.simps[code]
declare arith_ops.euclid_ext_aux_i.simps[code]
unbundle lifting_syntax
locale ring_ops = arith_ops ops for ops :: "'i arith_ops_record" +
fixes R :: "'i ⇒ 'a :: comm_ring_1 ⇒ bool"
assumes bi_unique[transfer_rule]: "bi_unique R"
and right_total[transfer_rule]: "right_total R"
and zero[transfer_rule]: "R zero 0"
and one[transfer_rule]: "R one 1"
and plus[transfer_rule]: "(R ===> R ===> R) plus (+)"
and minus[transfer_rule]: "(R ===> R ===> R) minus (-)"
and uminus[transfer_rule]: "(R ===> R) uminus Groups.uminus"
and times[transfer_rule]: "(R ===> R ===> R) times ((*))"
and eq[transfer_rule]: "(R ===> R ===> (=)) (=) (=)"
and DPR[transfer_domain_rule]: "Domainp R = DP"
begin
lemma left_right_unique[transfer_rule]: "left_unique R" "right_unique R"
using bi_unique unfolding bi_unique_def left_unique_def right_unique_def by auto
lemma listprod_i[transfer_rule]: "(list_all2 R ===> R) (listprod_i ops) prod_list"
proof (intro rel_funI, goal_cases)
case (1 xs ys)
thus ?case
proof (induct xs ys rule: list_all2_induct)
case (Cons x xs y ys)
note [transfer_rule] = this
show ?case by simp transfer_prover
qed (simp add: one)
qed
end
locale idom_ops = ring_ops ops R for ops :: "'i arith_ops_record" and
R :: "'i ⇒ 'a :: idom ⇒ bool"
locale idom_divide_ops = idom_ops ops R for ops :: "'i arith_ops_record" and
R :: "'i ⇒ 'a :: idom_divide ⇒ bool" +
assumes divide[transfer_rule]: "(R ===> R ===> R) divide Rings.divide"
locale euclidean_semiring_ops = idom_ops ops R for ops :: "'i arith_ops_record" and
R :: "'i ⇒ 'a :: {idom,normalization_euclidean_semiring} ⇒ bool" +
assumes modulo[transfer_rule]: "(R ===> R ===> R) modulo (mod)"
and normalize[transfer_rule]: "(R ===> R) normalize Rings.normalize"
and unit_factor[transfer_rule]: "(R ===> R) unit_factor Rings.unit_factor"
begin
lemma gcd_eucl_i [transfer_rule]: "(R ===> R ===> R) gcd_eucl_i Euclidean_Algorithm.gcd"
proof (intro rel_funI, goal_cases)
case (1 x X y Y)
thus ?case
proof (induct X Y arbitrary: x y rule: Euclidean_Algorithm.gcd.induct)
case (1 X Y x y)
note [transfer_rule] = 1(2-)
note simps = gcd_eucl_i.simps[of x y] Euclidean_Algorithm.gcd.simps[of X Y]
have eq: "(y = zero) = (Y = 0)" by transfer_prover
show ?case
proof (cases "Y = 0")
case True
hence *: "y = zero" using eq by simp
have "R (normalize x) (Rings.normalize X)" by transfer_prover
thus ?thesis unfolding simps unfolding True * by simp
next
case False
with eq have yz: "y ≠ zero" by simp
have "R (gcd_eucl_i y (modulo x y)) (Euclidean_Algorithm.gcd Y (X mod Y))"
by (rule 1(1)[OF False], transfer_prover+)
thus ?thesis unfolding simps using False yz by simp
qed
qed
qed
end
locale euclidean_ring_ops = euclidean_semiring_ops ops R for ops :: "'i arith_ops_record" and
R :: "'i ⇒ 'a :: {idom,euclidean_ring_gcd} ⇒ bool" +
assumes divide[transfer_rule]: "(R ===> R ===> R) divide (div)"
begin
lemma euclid_ext_aux_i[transfer_rule]:
"(R ===> R ===> R ===> R ===> R ===> R ===> rel_prod (rel_prod R R) R) euclid_ext_aux_i euclid_ext_aux"
proof (intro rel_funI, goal_cases)
case (1 z Z a A b B c C x X y Y)
thus ?case
proof (induct Z A B C X Y arbitrary: z a b c x y rule: euclid_ext_aux.induct)
case (1 Z A B C X Y z a b c x y)
note [transfer_rule] = 1(2-)
note simps = euclid_ext_aux_i.simps[of z a b c x y] euclid_ext_aux.simps[of Z A B C X Y]
have eq: "(y = zero) = (Y = 0)" by transfer_prover
show ?case
proof (cases "Y = 0")
case True
hence *: "(y = zero) = True" "(Y = 0) = True" using eq by auto
show ?thesis unfolding simps unfolding * if_True
by transfer_prover
next
case False
hence *: "(y = zero) = False" "(Y = 0) = False" using eq by auto
have XY: "R (modulo x y) (X mod Y)" by transfer_prover
have YA: "R (minus z (times (divide x y) a)) (Z - X div Y * A)" by transfer_prover
have YC: "R (minus b (times (divide x y) c)) (B - X div Y * C)" by transfer_prover
note [transfer_rule] = 1(1)[OF False refl 1(3) YA 1(5) YC 1(7) XY]
show ?thesis unfolding simps * if_False Let_def by transfer_prover
qed
qed
qed
lemma euclid_ext_i [transfer_rule]:
"(R ===> R ===> rel_prod (rel_prod R R) R) euclid_ext_i euclid_ext"
by transfer_prover
end
locale field_ops = idom_divide_ops ops R + euclidean_semiring_ops ops R for ops :: "'i arith_ops_record" and
R :: "'i ⇒ 'a :: {field_gcd} ⇒ bool" +
assumes inverse[transfer_rule]: "(R ===> R) inverse Fields.inverse"
lemma nth_default_rel[transfer_rule]: "(S ===> list_all2 S ===> (=) ===> S) nth_default nth_default"
proof (intro rel_funI, clarify, goal_cases)
case (1 x y xs ys _ n)
from 1(2) show ?case
proof (induct arbitrary: n)
case Nil
thus ?case using 1(1) by simp
next
case (Cons x y xs ys n)
thus ?case by (cases n, auto)
qed
qed
lemma strip_while_rel[transfer_rule]:
"((A ===> (=)) ===> list_all2 A ===> list_all2 A) strip_while strip_while"
unfolding strip_while_def[abs_def] by transfer_prover
lemma list_all2_last[simp]: "list_all2 A (xs @ [x]) (ys @ [y]) ⟷ list_all2 A xs ys ∧ A x y"
proof (cases "length xs = length ys")
case True
show ?thesis by (simp add: list_all2_append[OF True])
next
case False
note len = list_all2_lengthD[of A]
from len[of xs ys] len[of "xs @ [x]" "ys @ [y]"] False
show ?thesis by auto
qed
end
Theory Finite_Field_Record_Based
subsection ‹Finite Fields›
text ‹We provide four implementations for $GF(p)$ -- the field with $p$ elements for some
prime $p$ -- one by int, one by integers, one by 32-bit numbers and one 64-bit implementation.
Correctness of the implementations is proven by
transfer rules to the type-based version of $GF(p)$.›
theory Finite_Field_Record_Based
imports
Finite_Field
Arithmetic_Record_Based
Native_Word.Uint32
Native_Word.Uint64
Native_Word.Code_Target_Bits_Int
"HOL-Library.Code_Target_Numeral"
begin
definition mod_nonneg_pos :: "integer ⇒ integer ⇒ integer" where
"x ≥ 0 ⟹ y > 0 ⟹ mod_nonneg_pos x y = (x mod y)"
code_printing
constant mod_nonneg_pos ⇀
(SML) "IntInf.mod/ ( _,/ _ )"
and (Eval) "IntInf.mod/ ( _,/ _ )"
and (OCaml) "Z.rem"
and (Haskell) "Prelude.mod/ ( _ )/ ( _ )"
and (Scala) "!((k: BigInt) => (l: BigInt) =>/ (k '% l))"
definition mod_nonneg_pos_int :: "int ⇒ int ⇒ int" where
"mod_nonneg_pos_int x y = int_of_integer (mod_nonneg_pos (integer_of_int x) (integer_of_int y))"
lemma mod_nonneg_pos_int[simp]: "x ≥ 0 ⟹ y > 0 ⟹ mod_nonneg_pos_int x y = (x mod y)"
unfolding mod_nonneg_pos_int_def using mod_nonneg_pos_def by simp
context
fixes p :: int
begin
definition plus_p :: "int ⇒ int ⇒ int" where
"plus_p x y ≡ let z = x + y in if z ≥ p then z - p else z"
definition minus_p :: "int ⇒ int ⇒ int" where
"minus_p x y ≡ if y ≤ x then x - y else x + p - y"
definition uminus_p :: "int ⇒ int" where
"uminus_p x = (if x = 0 then 0 else p - x)"
definition mult_p :: "int ⇒ int ⇒ int" where
"mult_p x y = (mod_nonneg_pos_int (x * y) p)"
fun power_p :: "int ⇒ nat ⇒ int" where
"power_p x n = (if n = 0 then 1 else
let (d,r) = Divides.divmod_nat n 2;
rec = power_p (mult_p x x) d in
if r = 0 then rec else mult_p rec x)"
text ‹In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
it turned out that taking the below implementation of inverse via exponentiation
is faster than the one based on the extended Euclidean algorithm.›
definition inverse_p :: "int ⇒ int" where
"inverse_p x = (if x = 0 then 0 else power_p x (nat (p - 2)))"
definition divide_p :: "int ⇒ int ⇒ int" where
"divide_p x y = mult_p x (inverse_p y)"
definition finite_field_ops_int :: "int arith_ops_record" where
"finite_field_ops_int ≡ Arith_Ops_Record
0
1
plus_p
mult_p
minus_p
uminus_p
divide_p
inverse_p
(λ x y . if y = 0 then x else 0)
(λ x . if x = 0 then 0 else 1)
(λ x . x)
(λ x . x)
(λ x . x)
(λ x. 0 ≤ x ∧ x < p)"
end
context
fixes p :: uint32
begin
definition plus_p32 :: "uint32 ⇒ uint32 ⇒ uint32" where
"plus_p32 x y ≡ let z = x + y in if z ≥ p then z - p else z"
definition minus_p32 :: "uint32 ⇒ uint32 ⇒ uint32" where
"minus_p32 x y ≡ if y ≤ x then x - y else (x + p) - y"
definition uminus_p32 :: "uint32 ⇒ uint32" where
"uminus_p32 x = (if x = 0 then 0 else p - x)"
definition mult_p32 :: "uint32 ⇒ uint32 ⇒ uint32" where
"mult_p32 x y = (x * y mod p)"
lemma int_of_uint32_shift: "int_of_uint32 (shiftr n k) = (int_of_uint32 n) div (2 ^ k)"
apply transfer
apply transfer
apply (simp add: take_bit_drop_bit min_def)
apply (simp add: drop_bit_eq_div)
done
lemma int_of_uint32_0_iff: "int_of_uint32 n = 0 ⟷ n = 0"
by (transfer, rule uint_0_iff)
lemma int_of_uint32_0: "int_of_uint32 0 = 0" unfolding int_of_uint32_0_iff by simp
lemma int_of_uint32_ge_0: "int_of_uint32 n ≥ 0"
by (transfer, auto)
lemma two_32: "2 ^ LENGTH(32) = (4294967296 :: int)" by simp
lemma int_of_uint32_plus: "int_of_uint32 (x + y) = (int_of_uint32 x + int_of_uint32 y) mod 4294967296"
by (transfer, unfold uint_word_ariths two_32, rule refl)
lemma int_of_uint32_minus: "int_of_uint32 (x - y) = (int_of_uint32 x - int_of_uint32 y) mod 4294967296"
by (transfer, unfold uint_word_ariths two_32, rule refl)
lemma int_of_uint32_mult: "int_of_uint32 (x * y) = (int_of_uint32 x * int_of_uint32 y) mod 4294967296"
by (transfer, unfold uint_word_ariths two_32, rule refl)
lemma int_of_uint32_mod: "int_of_uint32 (x mod y) = (int_of_uint32 x mod int_of_uint32 y)"
by (transfer, unfold uint_mod two_32, rule refl)
lemma int_of_uint32_inv: "0 ≤ x ⟹ x < 4294967296 ⟹ int_of_uint32 (uint32_of_int x) = x"
by transfer (simp add: take_bit_int_eq_self)
function power_p32 :: "uint32 ⇒ uint32 ⇒ uint32" where
"power_p32 x n = (if n = 0 then 1 else
let rec = power_p32 (mult_p32 x x) (shiftr n 1) in
if n AND 1 = 0 then rec else mult_p32 rec x)"
by pat_completeness auto
termination
proof -
{
fix n :: uint32
assume "n ≠ 0"
with int_of_uint32_ge_0[of n] int_of_uint32_0_iff[of n] have "int_of_uint32 n > 0" by auto
hence "0 < int_of_uint32 n" "int_of_uint32 n div 2 < int_of_uint32 n" by auto
} note * = this
show ?thesis
by (relation "measure (λ (x,n). nat (int_of_uint32 n))", auto simp: int_of_uint32_shift *)
qed
text ‹In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
it turned out that taking the below implementation of inverse via exponentiation
is faster than the one based on the extended Euclidean algorithm.›
definition inverse_p32 :: "uint32 ⇒ uint32" where
"inverse_p32 x = (if x = 0 then 0 else power_p32 x (p - 2))"
definition divide_p32 :: "uint32 ⇒ uint32 ⇒ uint32" where
"divide_p32 x y = mult_p32 x (inverse_p32 y)"
definition finite_field_ops32 :: "uint32 arith_ops_record" where
"finite_field_ops32 ≡ Arith_Ops_Record
0
1
plus_p32
mult_p32
minus_p32
uminus_p32
divide_p32
inverse_p32
(λ x y . if y = 0 then x else 0)
(λ x . if x = 0 then 0 else 1)
(λ x . x)
uint32_of_int
int_of_uint32
(λ x. 0 ≤ x ∧ x < p)"
end
lemma shiftr_uint32_code [code_unfold]: "drop_bit 1 x = (uint32_shiftr x 1)"
by (simp add: uint32_shiftr_def shiftr_eq_drop_bit)
subsubsection ‹Transfer Relation›
locale mod_ring_locale =
fixes p :: int and ty :: "'a :: nontriv itself"
assumes p: "p = int CARD('a)"
begin
lemma nat_p: "nat p = CARD('a)" unfolding p by simp
lemma p2: "p ≥ 2" unfolding p using nontriv[where 'a = 'a] by auto
lemma p2_ident: "int (CARD('a) - 2) = p - 2" using p2 unfolding p by simp
definition mod_ring_rel :: "int ⇒ 'a mod_ring ⇒ bool" where
"mod_ring_rel x x' = (x = to_int_mod_ring x')"
lemma Domainp_mod_ring_rel [transfer_domain_rule]:
"Domainp (mod_ring_rel) = (λ v. v ∈ {0 ..< p})"
proof -
{
fix v :: int
assume *: "0 ≤ v" "v < p"
have "Domainp mod_ring_rel v"
proof
show "mod_ring_rel v (of_int_mod_ring v)" unfolding mod_ring_rel_def using * p by auto
qed
} note * = this
show ?thesis
by (intro ext iffI, insert range_to_int_mod_ring[where 'a = 'a] *, auto simp: mod_ring_rel_def p)
qed
lemma bi_unique_mod_ring_rel [transfer_rule]:
"bi_unique mod_ring_rel" "left_unique mod_ring_rel" "right_unique mod_ring_rel"
unfolding mod_ring_rel_def bi_unique_def left_unique_def right_unique_def
by auto
lemma right_total_mod_ring_rel [transfer_rule]: "right_total mod_ring_rel"
unfolding mod_ring_rel_def right_total_def by simp
subsubsection ‹Transfer Rules›
lemma mod_ring_0[transfer_rule]: "mod_ring_rel 0 0" unfolding mod_ring_rel_def by simp
lemma mod_ring_1[transfer_rule]: "mod_ring_rel 1 1" unfolding mod_ring_rel_def by simp
lemma plus_p_mod_def: assumes x: "x ∈ {0 ..< p}" and y: "y ∈ {0 ..< p}"
shows "plus_p p x y = ((x + y) mod p)"
proof (cases "p ≤ x + y")
case False
thus ?thesis using x y unfolding plus_p_def Let_def by auto
next
case True
from True x y have *: "p > 0" "0 ≤ x + y - p" "x + y - p < p" by auto
from True have id: "plus_p p x y = x + y - p" unfolding plus_p_def by auto
show ?thesis unfolding id using * using mod_pos_pos_trivial by fastforce
qed
lemma mod_ring_plus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (plus_p p) (+)"
proof -
{
fix x y :: "'a mod_ring"
have "plus_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x + y)"
by (transfer, subst plus_p_mod_def, auto, auto simp: p)
} note * = this
show ?thesis
by (intro rel_funI, auto simp: mod_ring_rel_def *)
qed
lemma minus_p_mod_def: assumes x: "x ∈ {0 ..< p}" and y: "y ∈ {0 ..< p}"
shows "minus_p p x y = ((x - y) mod p)"
proof (cases "x - y < 0")
case False
thus ?thesis using x y unfolding minus_p_def Let_def by auto
next
case True
from True x y have *: "p > 0" "0 ≤ x - y + p" "x - y + p < p" by auto
from True have id: "minus_p p x y = x - y + p" unfolding minus_p_def by auto
show ?thesis unfolding id using * using mod_pos_pos_trivial by fastforce
qed
lemma mod_ring_minus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (minus_p p) (-)"
proof -
{
fix x y :: "'a mod_ring"
have "minus_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x - y)"
by (transfer, subst minus_p_mod_def, auto simp: p)
} note * = this
show ?thesis
by (intro rel_funI, auto simp: mod_ring_rel_def *)
qed
lemma mod_ring_uminus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (uminus_p p) uminus"
proof -
{
fix x :: "'a mod_ring"
have "uminus_p p (to_int_mod_ring x) = to_int_mod_ring (uminus x)"
by (transfer, auto simp: uminus_p_def p)
} note * = this
show ?thesis
by (intro rel_funI, auto simp: mod_ring_rel_def *)
qed
lemma mod_ring_mult[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (mult_p p) ((*))"
proof -
{
fix x y :: "'a mod_ring"
have "mult_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x * y)"
by (transfer, auto simp: mult_p_def p)
} note * = this
show ?thesis
by (intro rel_funI, auto simp: mod_ring_rel_def *)
qed
lemma mod_ring_eq[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> (=)) (=) (=)"
by (intro rel_funI, auto simp: mod_ring_rel_def)
lemma mod_ring_power[transfer_rule]: "(mod_ring_rel ===> (=) ===> mod_ring_rel) (power_p p) (^)"
proof (intro rel_funI, clarify, unfold binary_power[symmetric], goal_cases)
fix x y n
assume xy: "mod_ring_rel x y"
from xy show "mod_ring_rel (power_p p x n) (binary_power y n)"
proof (induct y n arbitrary: x rule: binary_power.induct)
case (1 x n y)
note 1(2)[transfer_rule]
show ?case
proof (cases "n = 0")
case True
thus ?thesis by (simp add: mod_ring_1)
next
case False
obtain d r where id: "Divides.divmod_nat n 2 = (d,r)" by force
let ?int = "power_p p (mult_p p y y) d"
let ?gfp = "binary_power (x * x) d"
from False have id': "?thesis = (mod_ring_rel
(if r = 0 then ?int else mult_p p ?int y)
(if r = 0 then ?gfp else ?gfp * x))"
unfolding power_p.simps[of _ _ n] binary_power.simps[of _ n] Let_def id split by simp
have [transfer_rule]: "mod_ring_rel ?int ?gfp"
by (rule 1(1)[OF False refl id[symmetric]], transfer_prover)
show ?thesis unfolding id' by transfer_prover
qed
qed
qed
declare power_p.simps[simp del]
lemma ring_finite_field_ops_int: "ring_ops (finite_field_ops_int p) mod_ring_rel"
by (unfold_locales, auto simp:
finite_field_ops_int_def
bi_unique_mod_ring_rel
right_total_mod_ring_rel
mod_ring_plus
mod_ring_minus
mod_ring_uminus
mod_ring_mult
mod_ring_eq
mod_ring_0
mod_ring_1
Domainp_mod_ring_rel)
end
locale prime_field = mod_ring_locale p ty for p and ty :: "'a :: prime_card itself"
begin
lemma prime: "prime p" unfolding p using prime_card[where 'a = 'a] by simp
lemma mod_ring_mod[transfer_rule]:
"(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) ((λ x y. if y = 0 then x else 0)) (mod)"
proof -
{
fix x y :: "'a mod_ring"
have "(if to_int_mod_ring y = 0 then to_int_mod_ring x else 0) = to_int_mod_ring (x mod y)"
unfolding modulo_mod_ring_def by auto
} note * = this
show ?thesis
by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
qed
lemma mod_ring_normalize[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) ((λ x. if x = 0 then 0 else 1)) normalize"
proof -
{
fix x :: "'a mod_ring"
have "(if to_int_mod_ring x = 0 then 0 else 1) = to_int_mod_ring (normalize x)"
unfolding normalize_mod_ring_def by auto
} note * = this
show ?thesis
by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
qed
lemma mod_ring_unit_factor[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (λ x. x) unit_factor"
proof -
{
fix x :: "'a mod_ring"
have "to_int_mod_ring x = to_int_mod_ring (unit_factor x)"
unfolding unit_factor_mod_ring_def by auto
} note * = this
show ?thesis
by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
qed
lemma mod_ring_inverse[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (inverse_p p) inverse"
proof (intro rel_funI)
fix x y
assume [transfer_rule]: "mod_ring_rel x y"
show "mod_ring_rel (inverse_p p x) (inverse y)"
unfolding inverse_p_def inverse_mod_ring_def
apply (transfer_prover_start)
apply (transfer_step)+
apply (unfold p2_ident)
apply (rule refl)
done
qed
lemma mod_ring_divide[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel)
(divide_p p) (/)"
unfolding divide_p_def[abs_def] divide_mod_ring_def[abs_def] inverse_mod_ring_def[symmetric]
by transfer_prover
lemma mod_ring_rel_unsafe: assumes "x < CARD('a)"
shows "mod_ring_rel (int x) (of_nat x)" "0 < x ⟹ of_nat x ≠ (0 :: 'a mod_ring)"
proof -
have id: "of_nat x = (of_int (int x) :: 'a mod_ring)" by simp
show "mod_ring_rel (int x) (of_nat x)" "0 < x ⟹ of_nat x ≠ (0 :: 'a mod_ring)" unfolding id
unfolding mod_ring_rel_def
proof (auto simp add: assms of_int_of_int_mod_ring)
assume "0 < x" with assms
have "of_int_mod_ring (int x) ≠ (0 :: 'a mod_ring)"
by (metis (no_types) less_imp_of_nat_less less_irrefl of_nat_0_le_iff of_nat_0_less_iff to_int_mod_ring_hom.hom_zero to_int_mod_ring_of_int_mod_ring)
thus "of_int_mod_ring (int x) = (0 :: 'a mod_ring) ⟹ False" by blast
qed
qed
lemma finite_field_ops_int: "field_ops (finite_field_ops_int p) mod_ring_rel"
by (unfold_locales, auto simp:
finite_field_ops_int_def
bi_unique_mod_ring_rel
right_total_mod_ring_rel
mod_ring_divide
mod_ring_plus
mod_ring_minus
mod_ring_uminus
mod_ring_inverse
mod_ring_mod
mod_ring_unit_factor
mod_ring_normalize
mod_ring_mult
mod_ring_eq
mod_ring_0
mod_ring_1
Domainp_mod_ring_rel)
end
text ‹Once we have proven the soundness of the implementation, we do not care any longer
that @{typ "'a mod_ring"} has been defined internally via lifting. Disabling the transfer-rules
will hide the internal definition in further applications of transfer.›
lifting_forget mod_ring.lifting
text ‹For soundness of the 32-bit implementation, we mainly prove that this implementation
implements the int-based implementation of the mod-ring.›
context mod_ring_locale
begin
context fixes pp :: "uint32"
assumes ppp: "p = int_of_uint32 pp"
and small: "p ≤ 65535"
begin
lemmas uint32_simps =
int_of_uint32_0
int_of_uint32_plus
int_of_uint32_minus
int_of_uint32_mult
definition urel32 :: "uint32 ⇒ int ⇒ bool" where "urel32 x y = (y = int_of_uint32 x ∧ y < p)"
definition mod_ring_rel32 :: "uint32 ⇒ 'a mod_ring ⇒ bool" where
"mod_ring_rel32 x y = (∃ z. urel32 x z ∧ mod_ring_rel z y)"
lemma urel32_0: "urel32 0 0" unfolding urel32_def using p2 by (simp, transfer, simp)
lemma urel32_1: "urel32 1 1" unfolding urel32_def using p2 by (simp, transfer, simp)
lemma le_int_of_uint32: "(x ≤ y) = (int_of_uint32 x ≤ int_of_uint32 y)"
by (transfer, simp add: word_le_def)
lemma urel32_plus: assumes "urel32 x y" "urel32 x' y'"
shows "urel32 (plus_p32 pp x x') (plus_p p y y')"
proof -
let ?x = "int_of_uint32 x"
let ?x' = "int_of_uint32 x'"
let ?p = "int_of_uint32 pp"
from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'"
and rel: "0 ≤ ?x" "?x < p"
"0 ≤ ?x'" "?x' ≤ p" unfolding urel32_def by auto
have le: "(pp ≤ x + x') = (?p ≤ ?x + ?x')" unfolding le_int_of_uint32
using rel small by (auto simp: uint32_simps)
show ?thesis
proof (cases "?p ≤ ?x + ?x'")
case True
hence True: "(?p ≤ ?x + ?x') = True" by simp
show ?thesis unfolding id
using small rel unfolding plus_p32_def plus_p_def Let_def urel32_def
unfolding ppp le True if_True
using True by (auto simp: uint32_simps)
next
case False
hence False: "(?p ≤ ?x + ?x') = False" by simp
show ?thesis unfolding id
using small rel unfolding plus_p32_def plus_p_def Let_def urel32_def
unfolding ppp le False if_False
using False by (auto simp: uint32_simps)
qed
qed
lemma urel32_minus: assumes "urel32 x y" "urel32 x' y'"
shows "urel32 (minus_p32 pp x x') (minus_p p y y')"
proof -
let ?x = "int_of_uint32 x"
let ?x' = "int_of_uint32 x'"
from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'"
and rel: "0 ≤ ?x" "?x < p"
"0 ≤ ?x'" "?x' ≤ p" unfolding urel32_def by auto
have le: "(x' ≤ x) = (?x' ≤ ?x)" unfolding le_int_of_uint32
using rel small by (auto simp: uint32_simps)
show ?thesis
proof (cases "?x' ≤ ?x")
case True
hence True: "(?x' ≤ ?x) = True" by simp
show ?thesis unfolding id
using small rel unfolding minus_p32_def minus_p_def Let_def urel32_def
unfolding ppp le True if_True
using True by (auto simp: uint32_simps)
next
case False
hence False: "(?x' ≤ ?x) = False" by simp
show ?thesis unfolding id
using small rel unfolding minus_p32_def minus_p_def Let_def urel32_def
unfolding ppp le False if_False
using False by (auto simp: uint32_simps)
qed
qed
lemma urel32_uminus: assumes "urel32 x y"
shows "urel32 (uminus_p32 pp x) (uminus_p p y)"
proof -
let ?x = "int_of_uint32 x"
from assms int_of_uint32_ge_0 have id: "y = ?x"
and rel: "0 ≤ ?x" "?x < p"
unfolding urel32_def by auto
have le: "(x = 0) = (?x = 0)" unfolding int_of_uint32_0_iff
using rel small by (auto simp: uint32_simps)
show ?thesis
proof (cases "?x = 0")
case True
hence True: "(?x = 0) = True" by simp
show ?thesis unfolding id
using small rel unfolding uminus_p32_def uminus_p_def Let_def urel32_def
unfolding ppp le True if_True
using True by (auto simp: uint32_simps)
next
case False
hence False: "(?x = 0) = False" by simp
show ?thesis unfolding id
using small rel unfolding uminus_p32_def uminus_p_def Let_def urel32_def
unfolding ppp le False if_False
using False by (auto simp: uint32_simps)
qed
qed
lemma urel32_mult: assumes "urel32 x y" "urel32 x' y'"
shows "urel32 (mult_p32 pp x x') (mult_p p y y')"
proof -
let ?x = "int_of_uint32 x"
let ?x' = "int_of_uint32 x'"
from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'"
and rel: "0 ≤ ?x" "?x < p"
"0 ≤ ?x'" "?x' < p" unfolding urel32_def by auto
from rel have "?x * ?x' < p * p" by (metis mult_strict_mono')
also have "… ≤ 65536 * 65536"
by (rule mult_mono, insert p2 small, auto)
finally have le: "?x * ?x' < 4294967296" by simp
show ?thesis unfolding id
using small rel unfolding mult_p32_def mult_p_def Let_def urel32_def
unfolding ppp
by (auto simp: uint32_simps, unfold int_of_uint32_mod int_of_uint32_mult,
subst mod_pos_pos_trivial[of _ 4294967296], insert le, auto)
qed
lemma urel32_eq: assumes "urel32 x y" "urel32 x' y'"
shows "(x = x') = (y = y')"
proof -
let ?x = "int_of_uint32 x"
let ?x' = "int_of_uint32 x'"
from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'"
unfolding urel32_def by auto
show ?thesis unfolding id by (transfer, transfer) rule
qed
lemma urel32_normalize:
assumes x: "urel32 x y"
shows "urel32 (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
unfolding urel32_eq[OF x urel32_0] using urel32_0 urel32_1 by auto
lemma urel32_mod:
assumes x: "urel32 x x'" and y: "urel32 y y'"
shows "urel32 (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
unfolding urel32_eq[OF y urel32_0] using urel32_0 x by auto
lemma urel32_power: "urel32 x x' ⟹ urel32 y (int y') ⟹ urel32 (power_p32 pp x y) (power_p p x' y')"
proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
case (1 x' y' x y)
note x = 1(2) note y = 1(3)
show ?case
proof (cases "y' = 0")
case True
hence y: "y = 0" using urel32_eq[OF y urel32_0] by auto
show ?thesis unfolding y True by (simp add: power_p.simps urel32_1)
next
case False
hence id: "(y = 0) = False" "(y' = 0) = False" using urel32_eq[OF y urel32_0] by auto
obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
from divmod_nat_def[of y' 2, unfolded dr']
have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
have "urel32 (y AND 1) r'"
unfolding r'
using y
unfolding urel32_def
using small
apply (simp add: ppp and_one_eq)
apply transfer
apply transfer
apply (auto simp add: zmod_int take_bit_int_eq_self)
apply (rule le_less_trans)
apply (rule zmod_le_nonneg_dividend)
apply simp_all
done
from urel32_eq[OF this urel32_0]
have rem: "(y AND 1 = 0) = (r' = 0)" by simp
have div: "urel32 (shiftr y 1) (int d')" unfolding d' using y unfolding urel32_def using small
unfolding ppp
apply transfer
apply transfer
apply (auto simp add: drop_bit_Suc)
done
note IH = 1(1)[OF False refl dr'[symmetric] urel32_mult[OF x x] div]
show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p32.simps[of _ _ y] dr' id if_False rem
using IH urel32_mult[OF IH x] by (auto simp: Let_def)
qed
qed
lemma urel32_inverse: assumes x: "urel32 x x'"
shows "urel32 (inverse_p32 pp x) (inverse_p p x')"
proof -
have p: "urel32 (pp - 2) (int (nat (p - 2)))" using p2 small unfolding urel32_def unfolding ppp
by (transfer, auto simp: uint_word_ariths)
show ?thesis
unfolding inverse_p32_def inverse_p_def urel32_eq[OF x urel32_0] using urel32_0 urel32_power[OF x p]
by auto
qed
lemma mod_ring_0_32: "mod_ring_rel32 0 0"
using urel32_0 mod_ring_0 unfolding mod_ring_rel32_def by blast
lemma mod_ring_1_32: "mod_ring_rel32 1 1"
using urel32_1 mod_ring_1 unfolding mod_ring_rel32_def by blast
lemma mod_ring_uminus32: "(mod_ring_rel32 ===> mod_ring_rel32) (uminus_p32 pp) uminus"
using urel32_uminus mod_ring_uminus unfolding mod_ring_rel32_def rel_fun_def by blast
lemma mod_ring_plus32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (plus_p32 pp) (+)"
using urel32_plus mod_ring_plus unfolding mod_ring_rel32_def rel_fun_def by blast
lemma mod_ring_minus32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (minus_p32 pp) (-)"
using urel32_minus mod_ring_minus unfolding mod_ring_rel32_def rel_fun_def by blast
lemma mod_ring_mult32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (mult_p32 pp) ((*))"
using urel32_mult mod_ring_mult unfolding mod_ring_rel32_def rel_fun_def by blast
lemma mod_ring_eq32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> (=)) (=) (=)"
using urel32_eq mod_ring_eq unfolding mod_ring_rel32_def rel_fun_def by blast
lemma urel32_inj: "urel32 x y ⟹ urel32 x z ⟹ y = z"
using urel32_eq[of x y x z] by auto
lemma urel32_inj': "urel32 x z ⟹ urel32 y z ⟹ x = y"
using urel32_eq[of x z y z] by auto
lemma bi_unique_mod_ring_rel32:
"bi_unique mod_ring_rel32" "left_unique mod_ring_rel32" "right_unique mod_ring_rel32"
using bi_unique_mod_ring_rel urel32_inj'
unfolding mod_ring_rel32_def bi_unique_def left_unique_def right_unique_def
by (auto simp: urel32_def)
lemma right_total_mod_ring_rel32: "right_total mod_ring_rel32"
unfolding mod_ring_rel32_def right_total_def
proof
fix y :: "'a mod_ring"
from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
obtain z where zy: "mod_ring_rel z y" by auto
hence zp: "0 ≤ z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
hence "urel32 (uint32_of_int z) z" unfolding urel32_def using small unfolding ppp
by (auto simp: int_of_uint32_inv)
with zy show "∃ x z. urel32 x z ∧ mod_ring_rel z y" by blast
qed
lemma Domainp_mod_ring_rel32: "Domainp mod_ring_rel32 = (λx. 0 ≤ x ∧ x < pp)"
proof
fix x
show "Domainp mod_ring_rel32 x = (0 ≤ x ∧ x < pp)"
unfolding Domainp.simps
unfolding mod_ring_rel32_def
proof
let ?i = "int_of_uint32"
assume *: "0 ≤ x ∧ x < pp"
hence "0 ≤ ?i x ∧ ?i x < p" using small unfolding ppp
by (transfer, auto simp: word_less_def)
hence "?i x ∈ {0 ..< p}" by auto
with Domainp_mod_ring_rel
have "Domainp mod_ring_rel (?i x)" by auto
from this[unfolded Domainp.simps]
obtain b where b: "mod_ring_rel (?i x) b" by auto
show "∃a b. x = a ∧ (∃z. urel32 a z ∧ mod_ring_rel z b)"
proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
show "urel32 x (?i x)" unfolding urel32_def using small * unfolding ppp
by (transfer, auto simp: word_less_def)
qed
next
assume "∃a b. x = a ∧ (∃z. urel32 a z ∧ mod_ring_rel z b)"
then obtain b z where xz: "urel32 x z" and zb: "mod_ring_rel z b" by auto
hence "Domainp mod_ring_rel z" by auto
with Domainp_mod_ring_rel have "0 ≤ z" "z < p" by auto
with xz show "0 ≤ x ∧ x < pp" unfolding urel32_def using small unfolding ppp
by (transfer, auto simp: word_less_def)
qed
qed
lemma ring_finite_field_ops32: "ring_ops (finite_field_ops32 pp) mod_ring_rel32"
by (unfold_locales, auto simp:
finite_field_ops32_def
bi_unique_mod_ring_rel32
right_total_mod_ring_rel32
mod_ring_plus32
mod_ring_minus32
mod_ring_uminus32
mod_ring_mult32
mod_ring_eq32
mod_ring_0_32
mod_ring_1_32
Domainp_mod_ring_rel32)
end
end
context prime_field
begin
context fixes pp :: "uint32"
assumes *: "p = int_of_uint32 pp" "p ≤ 65535"
begin
lemma mod_ring_normalize32: "(mod_ring_rel32 ===> mod_ring_rel32) (λx. if x = 0 then 0 else 1) normalize"
using urel32_normalize[OF *] mod_ring_normalize unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast
lemma mod_ring_mod32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (λx y. if y = 0 then x else 0) (mod)"
using urel32_mod[OF *] mod_ring_mod unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast
lemma mod_ring_unit_factor32: "(mod_ring_rel32 ===> mod_ring_rel32) (λx. x) unit_factor"
using mod_ring_unit_factor unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast
lemma mod_ring_inverse32: "(mod_ring_rel32 ===> mod_ring_rel32) (inverse_p32 pp) inverse"
using urel32_inverse[OF *] mod_ring_inverse unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast
lemma mod_ring_divide32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (divide_p32 pp) (/)"
using mod_ring_inverse32 mod_ring_mult32[OF *]
unfolding divide_p32_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
rel_fun_def by blast
lemma finite_field_ops32: "field_ops (finite_field_ops32 pp) mod_ring_rel32"
by (unfold_locales, insert ring_finite_field_ops32[OF *], auto simp:
ring_ops_def
finite_field_ops32_def
mod_ring_divide32
mod_ring_inverse32
mod_ring_mod32
mod_ring_normalize32)
end
end
context
fixes p :: uint64
begin
definition plus_p64 :: "uint64 ⇒ uint64 ⇒ uint64" where
"plus_p64 x y ≡ let z = x + y in if z ≥ p then z - p else z"
definition minus_p64 :: "uint64 ⇒ uint64 ⇒ uint64" where
"minus_p64 x y ≡ if y ≤ x then x - y else (x + p) - y"
definition uminus_p64 :: "uint64 ⇒ uint64" where
"uminus_p64 x = (if x = 0 then 0 else p - x)"
definition mult_p64 :: "uint64 ⇒ uint64 ⇒ uint64" where
"mult_p64 x y = (x * y mod p)"
lemma int_of_uint64_shift: "int_of_uint64 (shiftr n k) = (int_of_uint64 n) div (2 ^ k)"
apply transfer
apply transfer
apply (simp add: take_bit_drop_bit min_def)
apply (simp add: drop_bit_eq_div)
done
lemma int_of_uint64_0_iff: "int_of_uint64 n = 0 ⟷ n = 0"
by (transfer, rule uint_0_iff)
lemma int_of_uint64_0: "int_of_uint64 0 = 0" unfolding int_of_uint64_0_iff by simp
lemma int_of_uint64_ge_0: "int_of_uint64 n ≥ 0"
by (transfer, auto)
lemma two_64: "2 ^ LENGTH(64) = (18446744073709551616 :: int)" by simp
lemma int_of_uint64_plus: "int_of_uint64 (x + y) = (int_of_uint64 x + int_of_uint64 y) mod 18446744073709551616"
by (transfer, unfold uint_word_ariths two_64, rule refl)
lemma int_of_uint64_minus: "int_of_uint64 (x - y) = (int_of_uint64 x - int_of_uint64 y) mod 18446744073709551616"
by (transfer, unfold uint_word_ariths two_64, rule refl)
lemma int_of_uint64_mult: "int_of_uint64 (x * y) = (int_of_uint64 x * int_of_uint64 y) mod 18446744073709551616"
by (transfer, unfold uint_word_ariths two_64, rule refl)
lemma int_of_uint64_mod: "int_of_uint64 (x mod y) = (int_of_uint64 x mod int_of_uint64 y)"
by (transfer, unfold uint_mod two_64, rule refl)
lemma int_of_uint64_inv: "0 ≤ x ⟹ x < 18446744073709551616 ⟹ int_of_uint64 (uint64_of_int x) = x"
by transfer (simp add: take_bit_int_eq_self)
function power_p64 :: "uint64 ⇒ uint64 ⇒ uint64" where
"power_p64 x n = (if n = 0 then 1 else
let rec = power_p64 (mult_p64 x x) (shiftr n 1) in
if n AND 1 = 0 then rec else mult_p64 rec x)"
by pat_completeness auto
termination
proof -
{
fix n :: uint64
assume "n ≠ 0"
with int_of_uint64_ge_0[of n] int_of_uint64_0_iff[of n] have "int_of_uint64 n > 0" by auto
hence "0 < int_of_uint64 n" "int_of_uint64 n div 2 < int_of_uint64 n" by auto
} note * = this
show ?thesis
by (relation "measure (λ (x,n). nat (int_of_uint64 n))", auto simp: int_of_uint64_shift *)
qed
text ‹In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
it turned out that taking the below implementation of inverse via exponentiation
is faster than the one based on the extended Euclidean algorithm.›
definition inverse_p64 :: "uint64 ⇒ uint64" where
"inverse_p64 x = (if x = 0 then 0 else power_p64 x (p - 2))"
definition divide_p64 :: "uint64 ⇒ uint64 ⇒ uint64" where
"divide_p64 x y = mult_p64 x (inverse_p64 y)"
definition finite_field_ops64 :: "uint64 arith_ops_record" where
"finite_field_ops64 ≡ Arith_Ops_Record
0
1
plus_p64
mult_p64
minus_p64
uminus_p64
divide_p64
inverse_p64
(λ x y . if y = 0 then x else 0)
(λ x . if x = 0 then 0 else 1)
(λ x . x)
uint64_of_int
int_of_uint64
(λ x. 0 ≤ x ∧ x < p)"
end
lemma shiftr_uint64_code [code_unfold]: "drop_bit 1 x = (uint64_shiftr x 1)"
by (simp add: uint64_shiftr_def)
text ‹For soundness of the 64-bit implementation, we mainly prove that this implementation
implements the int-based implementation of GF(p).›
context mod_ring_locale
begin
context fixes pp :: "uint64"
assumes ppp: "p = int_of_uint64 pp"
and small: "p ≤ 4294967295"
begin
lemmas uint64_simps =
int_of_uint64_0
int_of_uint64_plus
int_of_uint64_minus
int_of_uint64_mult
definition urel64 :: "uint64 ⇒ int ⇒ bool" where "urel64 x y = (y = int_of_uint64 x ∧ y < p)"
definition mod_ring_rel64 :: "uint64 ⇒ 'a mod_ring ⇒ bool" where
"mod_ring_rel64 x y = (∃ z. urel64 x z ∧ mod_ring_rel z y)"
lemma urel64_0: "urel64 0 0" unfolding urel64_def using p2 by (simp, transfer, simp)
lemma urel64_1: "urel64 1 1" unfolding urel64_def using p2 by (simp, transfer, simp)
lemma le_int_of_uint64: "(x ≤ y) = (int_of_uint64 x ≤ int_of_uint64 y)"
by (transfer, simp add: word_le_def)
lemma urel64_plus: assumes "urel64 x y" "urel64 x' y'"
shows "urel64 (plus_p64 pp x x') (plus_p p y y')"
proof -
let ?x = "int_of_uint64 x"
let ?x' = "int_of_uint64 x'"
let ?p = "int_of_uint64 pp"
from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'"
and rel: "0 ≤ ?x" "?x < p"
"0 ≤ ?x'" "?x' ≤ p" unfolding urel64_def by auto
have le: "(pp ≤ x + x') = (?p ≤ ?x + ?x')" unfolding le_int_of_uint64
using rel small by (auto simp: uint64_simps)
show ?thesis
proof (cases "?p ≤ ?x + ?x'")
case True
hence True: "(?p ≤ ?x + ?x') = True" by simp
show ?thesis unfolding id
using small rel unfolding plus_p64_def plus_p_def Let_def urel64_def
unfolding ppp le True if_True
using True by (auto simp: uint64_simps)
next
case False
hence False: "(?p ≤ ?x + ?x') = False" by simp
show ?thesis unfolding id
using small rel unfolding plus_p64_def plus_p_def Let_def urel64_def
unfolding ppp le False if_False
using False by (auto simp: uint64_simps)
qed
qed
lemma urel64_minus: assumes "urel64 x y" "urel64 x' y'"
shows "urel64 (minus_p64 pp x x') (minus_p p y y')"
proof -
let ?x = "int_of_uint64 x"
let ?x' = "int_of_uint64 x'"
from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'"
and rel: "0 ≤ ?x" "?x < p"
"0 ≤ ?x'" "?x' ≤ p" unfolding urel64_def by auto
have le: "(x' ≤ x) = (?x' ≤ ?x)" unfolding le_int_of_uint64
using rel small by (auto simp: uint64_simps)
show ?thesis
proof (cases "?x' ≤ ?x")
case True
hence True: "(?x' ≤ ?x) = True" by simp
show ?thesis unfolding id
using small rel unfolding minus_p64_def minus_p_def Let_def urel64_def
unfolding ppp le True if_True
using True by (auto simp: uint64_simps)
next
case False
hence False: "(?x' ≤ ?x) = False" by simp
show ?thesis unfolding id
using small rel unfolding minus_p64_def minus_p_def Let_def urel64_def
unfolding ppp le False if_False
using False by (auto simp: uint64_simps)
qed
qed
lemma urel64_uminus: assumes "urel64 x y"
shows "urel64 (uminus_p64 pp x) (uminus_p p y)"
proof -
let ?x = "int_of_uint64 x"
from assms int_of_uint64_ge_0 have id: "y = ?x"
and rel: "0 ≤ ?x" "?x < p"
unfolding urel64_def by auto
have le: "(x = 0) = (?x = 0)" unfolding int_of_uint64_0_iff
using rel small by (auto simp: uint64_simps)
show ?thesis
proof (cases "?x = 0")
case True
hence True: "(?x = 0) = True" by simp
show ?thesis unfolding id
using small rel unfolding uminus_p64_def uminus_p_def Let_def urel64_def
unfolding ppp le True if_True
using True by (auto simp: uint64_simps)
next
case False
hence False: "(?x = 0) = False" by simp
show ?thesis unfolding id
using small rel unfolding uminus_p64_def uminus_p_def Let_def urel64_def
unfolding ppp le False if_False
using False by (auto simp: uint64_simps)
qed
qed
lemma urel64_mult: assumes "urel64 x y" "urel64 x' y'"
shows "urel64 (mult_p64 pp x x') (mult_p p y y')"
proof -
let ?x = "int_of_uint64 x"
let ?x' = "int_of_uint64 x'"
from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'"
and rel: "0 ≤ ?x" "?x < p"
"0 ≤ ?x'" "?x' < p" unfolding urel64_def by auto
from rel have "?x * ?x' < p * p" by (metis mult_strict_mono')
also have "… ≤ 4294967296 * 4294967296"
by (rule mult_mono, insert p2 small, auto)
finally have le: "?x * ?x' < 18446744073709551616" by simp
show ?thesis unfolding id
using small rel unfolding mult_p64_def mult_p_def Let_def urel64_def
unfolding ppp
by (auto simp: uint64_simps, unfold int_of_uint64_mod int_of_uint64_mult,
subst mod_pos_pos_trivial[of _ 18446744073709551616], insert le, auto)
qed
lemma urel64_eq: assumes "urel64 x y" "urel64 x' y'"
shows "(x = x') = (y = y')"
proof -
let ?x = "int_of_uint64 x"
let ?x' = "int_of_uint64 x'"
from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'"
unfolding urel64_def by auto
show ?thesis unfolding id by (transfer, transfer) rule
qed
lemma urel64_normalize:
assumes x: "urel64 x y"
shows "urel64 (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
unfolding urel64_eq[OF x urel64_0] using urel64_0 urel64_1 by auto
lemma urel64_mod:
assumes x: "urel64 x x'" and y: "urel64 y y'"
shows "urel64 (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
unfolding urel64_eq[OF y urel64_0] using urel64_0 x by auto
lemma urel64_power: "urel64 x x' ⟹ urel64 y (int y') ⟹ urel64 (power_p64 pp x y) (power_p p x' y')"
proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
case (1 x' y' x y)
note x = 1(2) note y = 1(3)
show ?case
proof (cases "y' = 0")
case True
hence y: "y = 0" using urel64_eq[OF y urel64_0] by auto
show ?thesis unfolding y True by (simp add: power_p.simps urel64_1)
next
case False
hence id: "(y = 0) = False" "(y' = 0) = False" using urel64_eq[OF y urel64_0] by auto
obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
from divmod_nat_def[of y' 2, unfolded dr']
have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
have "urel64 (y AND 1) r'"
unfolding r'
using y
unfolding urel64_def
using small
apply (simp add: ppp and_one_eq)
apply transfer apply transfer
apply (auto simp add: int_eq_iff nat_take_bit_eq nat_mod_distrib zmod_int)
apply (auto simp add: zmod_int mod_2_eq_odd)
apply (metis (full_types) even_take_bit_eq le_less_trans odd_iff_mod_2_eq_one take_bit_nonnegative zero_neq_numeral zmod_le_nonneg_dividend)
apply (auto simp add: less_le)
apply (simp add: le_less)
done
from urel64_eq[OF this urel64_0]
have rem: "(y AND 1 = 0) = (r' = 0)" by simp
have div: "urel64 (shiftr y 1) (int d')" unfolding d' using y unfolding urel64_def using small
unfolding ppp
apply transfer
apply transfer
apply (auto simp add: drop_bit_Suc)
done
note IH = 1(1)[OF False refl dr'[symmetric] urel64_mult[OF x x] div]
show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p64.simps[of _ _ y] dr' id if_False rem
using IH urel64_mult[OF IH x] by (auto simp: Let_def)
qed
qed
lemma urel64_inverse: assumes x: "urel64 x x'"
shows "urel64 (inverse_p64 pp x) (inverse_p p x')"
proof -
have p: "urel64 (pp - 2) (int (nat (p - 2)))" using p2 small unfolding urel64_def unfolding ppp
by (transfer, auto simp: uint_word_ariths)
show ?thesis
unfolding inverse_p64_def inverse_p_def urel64_eq[OF x urel64_0] using urel64_0 urel64_power[OF x p]
by auto
qed
lemma mod_ring_0_64: "mod_ring_rel64 0 0"
using urel64_0 mod_ring_0 unfolding mod_ring_rel64_def by blast
lemma mod_ring_1_64: "mod_ring_rel64 1 1"
using urel64_1 mod_ring_1 unfolding mod_ring_rel64_def by blast
lemma mod_ring_uminus64: "(mod_ring_rel64 ===> mod_ring_rel64) (uminus_p64 pp) uminus"
using urel64_uminus mod_ring_uminus unfolding mod_ring_rel64_def rel_fun_def by blast
lemma mod_ring_plus64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (plus_p64 pp) (+)"
using urel64_plus mod_ring_plus unfolding mod_ring_rel64_def rel_fun_def by blast
lemma mod_ring_minus64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (minus_p64 pp) (-)"
using urel64_minus mod_ring_minus unfolding mod_ring_rel64_def rel_fun_def by blast
lemma mod_ring_mult64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (mult_p64 pp) ((*))"
using urel64_mult mod_ring_mult unfolding mod_ring_rel64_def rel_fun_def by blast
lemma mod_ring_eq64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> (=)) (=) (=)"
using urel64_eq mod_ring_eq unfolding mod_ring_rel64_def rel_fun_def by blast
lemma urel64_inj: "urel64 x y ⟹ urel64 x z ⟹ y = z"
using urel64_eq[of x y x z] by auto
lemma urel64_inj': "urel64 x z ⟹ urel64 y z ⟹ x = y"
using urel64_eq[of x z y z] by auto
lemma bi_unique_mod_ring_rel64:
"bi_unique mod_ring_rel64" "left_unique mod_ring_rel64" "right_unique mod_ring_rel64"
using bi_unique_mod_ring_rel urel64_inj'
unfolding mod_ring_rel64_def bi_unique_def left_unique_def right_unique_def
by (auto simp: urel64_def)
lemma right_total_mod_ring_rel64: "right_total mod_ring_rel64"
unfolding mod_ring_rel64_def right_total_def
proof
fix y :: "'a mod_ring"
from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
obtain z where zy: "mod_ring_rel z y" by auto
hence zp: "0 ≤ z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
hence "urel64 (uint64_of_int z) z" unfolding urel64_def using small unfolding ppp
by (auto simp: int_of_uint64_inv)
with zy show "∃ x z. urel64 x z ∧ mod_ring_rel z y" by blast
qed
lemma Domainp_mod_ring_rel64: "Domainp mod_ring_rel64 = (λx. 0 ≤ x ∧ x < pp)"
proof
fix x
show "Domainp mod_ring_rel64 x = (0 ≤ x ∧ x < pp)"
unfolding Domainp.simps
unfolding mod_ring_rel64_def
proof
let ?i = "int_of_uint64"
assume *: "0 ≤ x ∧ x < pp"
hence "0 ≤ ?i x ∧ ?i x < p" using small unfolding ppp
by (transfer, auto simp: word_less_def)
hence "?i x ∈ {0 ..< p}" by auto
with Domainp_mod_ring_rel
have "Domainp mod_ring_rel (?i x)" by auto
from this[unfolded Domainp.simps]
obtain b where b: "mod_ring_rel (?i x) b" by auto
show "∃a b. x = a ∧ (∃z. urel64 a z ∧ mod_ring_rel z b)"
proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
show "urel64 x (?i x)" unfolding urel64_def using small * unfolding ppp
by (transfer, auto simp: word_less_def)
qed
next
assume "∃a b. x = a ∧ (∃z. urel64 a z ∧ mod_ring_rel z b)"
then obtain b z where xz: "urel64 x z" and zb: "mod_ring_rel z b" by auto
hence "Domainp mod_ring_rel z" by auto
with Domainp_mod_ring_rel have "0 ≤ z" "z < p" by auto
with xz show "0 ≤ x ∧ x < pp" unfolding urel64_def using small unfolding ppp
by (transfer, auto simp: word_less_def)
qed
qed
lemma ring_finite_field_ops64: "ring_ops (finite_field_ops64 pp) mod_ring_rel64"
by (unfold_locales, auto simp:
finite_field_ops64_def
bi_unique_mod_ring_rel64
right_total_mod_ring_rel64
mod_ring_plus64
mod_ring_minus64
mod_ring_uminus64
mod_ring_mult64
mod_ring_eq64
mod_ring_0_64
mod_ring_1_64
Domainp_mod_ring_rel64)
end
end
context prime_field
begin
context fixes pp :: "uint64"
assumes *: "p = int_of_uint64 pp" "p ≤ 4294967295"
begin
lemma mod_ring_normalize64: "(mod_ring_rel64 ===> mod_ring_rel64) (λx. if x = 0 then 0 else 1) normalize"
using urel64_normalize[OF *] mod_ring_normalize unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast
lemma mod_ring_mod64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (λx y. if y = 0 then x else 0) (mod)"
using urel64_mod[OF *] mod_ring_mod unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast
lemma mod_ring_unit_factor64: "(mod_ring_rel64 ===> mod_ring_rel64) (λx. x) unit_factor"
using mod_ring_unit_factor unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast
lemma mod_ring_inverse64: "(mod_ring_rel64 ===> mod_ring_rel64) (inverse_p64 pp) inverse"
using urel64_inverse[OF *] mod_ring_inverse unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast
lemma mod_ring_divide64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (divide_p64 pp) (/)"
using mod_ring_inverse64 mod_ring_mult64[OF *]
unfolding divide_p64_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
rel_fun_def by blast
lemma finite_field_ops64: "field_ops (finite_field_ops64 pp) mod_ring_rel64"
by (unfold_locales, insert ring_finite_field_ops64[OF *], auto simp:
ring_ops_def
finite_field_ops64_def
mod_ring_divide64
mod_ring_inverse64
mod_ring_mod64
mod_ring_normalize64)
end
end
context
fixes p :: integer
begin
definition plus_p_integer :: "integer ⇒ integer ⇒ integer" where
"plus_p_integer x y ≡ let z = x + y in if z ≥ p then z - p else z"
definition minus_p_integer :: "integer ⇒ integer ⇒ integer" where
"minus_p_integer x y ≡ if y ≤ x then x - y else (x + p) - y"
definition uminus_p_integer :: "integer ⇒ integer" where
"uminus_p_integer x = (if x = 0 then 0 else p - x)"
definition mult_p_integer :: "integer ⇒ integer ⇒ integer" where
"mult_p_integer x y = (x * y mod p)"
lemma int_of_integer_0_iff: "int_of_integer n = 0 ⟷ n = 0"
using integer_eqI by auto
lemma int_of_integer_0: "int_of_integer 0 = 0" unfolding int_of_integer_0_iff by simp
lemma int_of_integer_plus: "int_of_integer (x + y) = (int_of_integer x + int_of_integer y)"
by simp
lemma int_of_integer_minus: "int_of_integer (x - y) = (int_of_integer x - int_of_integer y)"
by simp
lemma int_of_integer_mult: "int_of_integer (x * y) = (int_of_integer x * int_of_integer y)"
by simp
lemma int_of_integer_mod: "int_of_integer (x mod y) = (int_of_integer x mod int_of_integer y)"
by simp
lemma int_of_integer_inv: "int_of_integer (integer_of_int x) = x" by simp
lemma int_of_integer_shift: "int_of_integer (shiftr n k) = (int_of_integer n) div (2 ^ k)"
by transfer (simp add: int_of_integer_pow shiftr_integer_conv_div_pow2)
function power_p_integer :: "integer ⇒ integer ⇒ integer" where
"power_p_integer x n = (if n ≤ 0 then 1 else
let rec = power_p_integer (mult_p_integer x x) (shiftr n 1) in
if n AND 1 = 0 then rec else mult_p_integer rec x)"
by pat_completeness auto
termination
proof -
{
fix n :: integer
assume "¬ (n ≤ 0)"
hence "n > 0" by auto
hence "int_of_integer n > 0"
by (simp add: less_integer.rep_eq)
hence "0 < int_of_integer n" "int_of_integer n div 2 < int_of_integer n" by auto
} note * = this
show ?thesis
by (relation "measure (λ (x,n). nat (int_of_integer n))", auto simp: * int_of_integer_shift)
qed
text ‹In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
it turned out that taking the below implementation of inverse via exponentiation
is faster than the one based on the extended Euclidean algorithm.›
definition inverse_p_integer :: "integer ⇒ integer" where
"inverse_p_integer x = (if x = 0 then 0 else power_p_integer x (p - 2))"
definition divide_p_integer :: "integer ⇒ integer ⇒ integer" where
"divide_p_integer x y = mult_p_integer x (inverse_p_integer y)"
definition finite_field_ops_integer :: "integer arith_ops_record" where
"finite_field_ops_integer ≡ Arith_Ops_Record
0
1
plus_p_integer
mult_p_integer
minus_p_integer
uminus_p_integer
divide_p_integer
inverse_p_integer
(λ x y . if y = 0 then x else 0)
(λ x . if x = 0 then 0 else 1)
(λ x . x)
integer_of_int
int_of_integer
(λ x. 0 ≤ x ∧ x < p)"
end
lemma shiftr_integer_code [code_unfold]: "drop_bit 1 x = (integer_shiftr x 1)"
unfolding shiftr_integer_code using integer_of_nat_1 by auto
text ‹For soundness of the integer implementation, we mainly prove that this implementation
implements the int-based implementation of GF(p).›
context mod_ring_locale
begin
context fixes pp :: "integer"
assumes ppp: "p = int_of_integer pp"
begin
lemmas integer_simps =
int_of_integer_0
int_of_integer_plus
int_of_integer_minus
int_of_integer_mult
definition urel_integer :: "integer ⇒ int ⇒ bool" where "urel_integer x y = (y = int_of_integer x ∧ y ≥ 0 ∧ y < p)"
definition mod_ring_rel_integer :: "integer ⇒ 'a mod_ring ⇒ bool" where
"mod_ring_rel_integer x y = (∃ z. urel_integer x z ∧ mod_ring_rel z y)"
lemma urel_integer_0: "urel_integer 0 0" unfolding urel_integer_def using p2 by simp
lemma urel_integer_1: "urel_integer 1 1" unfolding urel_integer_def using p2 by simp
lemma le_int_of_integer: "(x ≤ y) = (int_of_integer x ≤ int_of_integer y)"
by (rule less_eq_integer.rep_eq)
lemma urel_integer_plus: assumes "urel_integer x y" "urel_integer x' y'"
shows "urel_integer (plus_p_integer pp x x') (plus_p p y y')"
proof -
let ?x = "int_of_integer x"
let ?x' = "int_of_integer x'"
let ?p = "int_of_integer pp"
from assms have id: "y = ?x" "y' = ?x'"
and rel: "0 ≤ ?x" "?x < p"
"0 ≤ ?x'" "?x' ≤ p" unfolding urel_integer_def by auto
have le: "(pp ≤ x + x') = (?p ≤ ?x + ?x')" unfolding le_int_of_integer
using rel by auto
show ?thesis
proof (cases "?p ≤ ?x + ?x'")
case True
hence True: "(?p ≤ ?x + ?x') = True" by simp
show ?thesis unfolding id
using rel unfolding plus_p_integer_def plus_p_def Let_def urel_integer_def
unfolding ppp le True if_True
using True by auto
next
case False
hence False: "(?p ≤ ?x + ?x') = False" by simp
show ?thesis unfolding id
using rel unfolding plus_p_integer_def plus_p_def Let_def urel_integer_def
unfolding ppp le False if_False
using False by auto
qed
qed
lemma urel_integer_minus: assumes "urel_integer x y" "urel_integer x' y'"
shows "urel_integer (minus_p_integer pp x x') (minus_p p y y')"
proof -
let ?x = "int_of_integer x"
let ?x' = "int_of_integer x'"
from assms have id: "y = ?x" "y' = ?x'"
and rel: "0 ≤ ?x" "?x < p"
"0 ≤ ?x'" "?x' ≤ p" unfolding urel_integer_def by auto
have le: "(x' ≤ x) = (?x' ≤ ?x)" unfolding le_int_of_integer
using rel by auto
show ?thesis
proof (cases "?x' ≤ ?x")
case True
hence True: "(?x' ≤ ?x) = True" by simp
show ?thesis unfolding id
using rel unfolding minus_p_integer_def minus_p_def Let_def urel_integer_def
unfolding ppp le True if_True
using True by auto
next
case False
hence False: "(?x' ≤ ?x) = False" by simp
show ?thesis unfolding id
using rel unfolding minus_p_integer_def minus_p_def Let_def urel_integer_def
unfolding ppp le False if_False
using False by auto
qed
qed
lemma urel_integer_uminus: assumes "urel_integer x y"
shows "urel_integer (uminus_p_integer pp x) (uminus_p p y)"
proof -
let ?x = "int_of_integer x"
from assms have id: "y = ?x"
and rel: "0 ≤ ?x" "?x < p"
unfolding urel_integer_def by auto
have le: "(x = 0) = (?x = 0)" unfolding int_of_integer_0_iff
using rel by auto
show ?thesis
proof (cases "?x = 0")
case True
hence True: "(?x = 0) = True" by simp
show ?thesis unfolding id
using rel unfolding uminus_p_integer_def uminus_p_def Let_def urel_integer_def
unfolding ppp le True if_True
using True by auto
next
case False
hence False: "(?x = 0) = False" by simp
show ?thesis unfolding id
using rel unfolding uminus_p_integer_def uminus_p_def Let_def urel_integer_def
unfolding ppp le False if_False
using False by auto
qed
qed
lemma pp_pos: "int_of_integer pp > 0"
using ppp nontriv[where 'a = 'a] unfolding p
by (simp add: less_integer.rep_eq)
lemma urel_integer_mult: assumes "urel_integer x y" "urel_integer x' y'"
shows "urel_integer (mult_p_integer pp x x') (mult_p p y y')"
proof -
let ?x = "int_of_integer x"
let ?x' = "int_of_integer x'"
from assms have id: "y = ?x" "y' = ?x'"
and rel: "0 ≤ ?x" "?x < p"
"0 ≤ ?x'" "?x' < p" unfolding urel_integer_def by auto
from rel(1,3) have xx: "0 ≤ ?x * ?x'" by simp
show ?thesis unfolding id
using rel unfolding mult_p_integer_def mult_p_def Let_def urel_integer_def
unfolding ppp mod_nonneg_pos_int[OF xx pp_pos] using xx pp_pos by simp
qed
lemma urel_integer_eq: assumes "urel_integer x y" "urel_integer x' y'"
shows "(x = x') = (y = y')"
proof -
let ?x = "int_of_integer x"
let ?x' = "int_of_integer x'"
from assms have id: "y = ?x" "y' = ?x'"
unfolding urel_integer_def by auto
show ?thesis unfolding id integer_eq_iff ..
qed
lemma urel_integer_normalize:
assumes x: "urel_integer x y"
shows "urel_integer (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
unfolding urel_integer_eq[OF x urel_integer_0] using urel_integer_0 urel_integer_1 by auto
lemma urel_integer_mod:
assumes x: "urel_integer x x'" and y: "urel_integer y y'"
shows "urel_integer (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
unfolding urel_integer_eq[OF y urel_integer_0] using urel_integer_0 x by auto
lemma urel_integer_power: "urel_integer x x' ⟹ urel_integer y (int y') ⟹ urel_integer (power_p_integer pp x y) (power_p p x' y')"
proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
case (1 x' y' x y)
note x = 1(2) note y = 1(3)
show ?case
proof (cases "y' ≤ 0")
case True
hence y: "y = 0" "y' = 0" using urel_integer_eq[OF y urel_integer_0] by auto
show ?thesis unfolding y True by (simp add: power_p.simps urel_integer_1)
next
case False
hence id: "(y ≤ 0) = False" "(y' = 0) = False" using False y
by (auto simp add: urel_integer_def not_le) (metis of_int_integer_of of_int_of_nat_eq of_nat_0_less_iff)
obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
from divmod_nat_def[of y' 2, unfolded dr']
have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
have aux: "⋀ y'. int (y' mod 2) = int y' mod 2" by presburger
have "urel_integer (y AND 1) r'" unfolding r' using y unfolding urel_integer_def
unfolding ppp
apply (auto simp add: and_one_eq)
apply (simp add: of_nat_mod)
done
from urel_integer_eq[OF this urel_integer_0]
have rem: "(y AND 1 = 0) = (r' = 0)" by simp
have div: "urel_integer (shiftr y 1) (int d')" unfolding d' using y unfolding urel_integer_def
unfolding ppp shiftr_integer_conv_div_pow2 by auto
from id have "y' ≠ 0" by auto
note IH = 1(1)[OF this refl dr'[symmetric] urel_integer_mult[OF x x] div]
show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p_integer.simps[of _ _ y] dr' id if_False rem
using IH urel_integer_mult[OF IH x] by (auto simp: Let_def)
qed
qed
lemma urel_integer_inverse: assumes x: "urel_integer x x'"
shows "urel_integer (inverse_p_integer pp x) (inverse_p p x')"
proof -
have p: "urel_integer (pp - 2) (int (nat (p - 2)))" using p2 unfolding urel_integer_def unfolding ppp
by auto
show ?thesis
unfolding inverse_p_integer_def inverse_p_def urel_integer_eq[OF x urel_integer_0] using urel_integer_0 urel_integer_power[OF x p]
by auto
qed
lemma mod_ring_0__integer: "mod_ring_rel_integer 0 0"
using urel_integer_0 mod_ring_0 unfolding mod_ring_rel_integer_def by blast
lemma mod_ring_1__integer: "mod_ring_rel_integer 1 1"
using urel_integer_1 mod_ring_1 unfolding mod_ring_rel_integer_def by blast
lemma mod_ring_uminus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (uminus_p_integer pp) uminus"
using urel_integer_uminus mod_ring_uminus unfolding mod_ring_rel_integer_def rel_fun_def by blast
lemma mod_ring_plus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (plus_p_integer pp) (+)"
using urel_integer_plus mod_ring_plus unfolding mod_ring_rel_integer_def rel_fun_def by blast
lemma mod_ring_minus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (minus_p_integer pp) (-)"
using urel_integer_minus mod_ring_minus unfolding mod_ring_rel_integer_def rel_fun_def by blast
lemma mod_ring_mult_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (mult_p_integer pp) ((*))"
using urel_integer_mult mod_ring_mult unfolding mod_ring_rel_integer_def rel_fun_def by blast
lemma mod_ring_eq_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> (=)) (=) (=)"
using urel_integer_eq mod_ring_eq unfolding mod_ring_rel_integer_def rel_fun_def by blast
lemma urel_integer_inj: "urel_integer x y ⟹ urel_integer x z ⟹ y = z"
using urel_integer_eq[of x y x z] by auto
lemma urel_integer_inj': "urel_integer x z ⟹ urel_integer y z ⟹ x = y"
using urel_integer_eq[of x z y z] by auto
lemma bi_unique_mod_ring_rel_integer:
"bi_unique mod_ring_rel_integer" "left_unique mod_ring_rel_integer" "right_unique mod_ring_rel_integer"
using bi_unique_mod_ring_rel urel_integer_inj'
unfolding mod_ring_rel_integer_def bi_unique_def left_unique_def right_unique_def
by (auto simp: urel_integer_def)
lemma right_total_mod_ring_rel_integer: "right_total mod_ring_rel_integer"
unfolding mod_ring_rel_integer_def right_total_def
proof
fix y :: "'a mod_ring"
from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
obtain z where zy: "mod_ring_rel z y" by auto
hence zp: "0 ≤ z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
hence "urel_integer (integer_of_int z) z" unfolding urel_integer_def unfolding ppp
by auto
with zy show "∃ x z. urel_integer x z ∧ mod_ring_rel z y" by blast
qed
lemma Domainp_mod_ring_rel_integer: "Domainp mod_ring_rel_integer = (λx. 0 ≤ x ∧ x < pp)"
proof
fix x
show "Domainp mod_ring_rel_integer x = (0 ≤ x ∧ x < pp)"
unfolding Domainp.simps
unfolding mod_ring_rel_integer_def
proof
let ?i = "int_of_integer"
assume *: "0 ≤ x ∧ x < pp"
hence "0 ≤ ?i x ∧ ?i x < p" unfolding ppp
by (simp add: le_int_of_integer less_integer.rep_eq)
hence "?i x ∈ {0 ..< p}" by auto
with Domainp_mod_ring_rel
have "Domainp mod_ring_rel (?i x)" by auto
from this[unfolded Domainp.simps]
obtain b where b: "mod_ring_rel (?i x) b" by auto
show "∃a b. x = a ∧ (∃z. urel_integer a z ∧ mod_ring_rel z b)"
proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
show "urel_integer x (?i x)" unfolding urel_integer_def using * unfolding ppp
by (simp add: le_int_of_integer less_integer.rep_eq)
qed
next
assume "∃a b. x = a ∧ (∃z. urel_integer a z ∧ mod_ring_rel z b)"
then obtain b z where xz: "urel_integer x z" and zb: "mod_ring_rel z b" by auto
hence "Domainp mod_ring_rel z" by auto
with Domainp_mod_ring_rel have "0 ≤ z" "z < p" by auto
with xz show "0 ≤ x ∧ x < pp" unfolding urel_integer_def unfolding ppp
by (simp add: le_int_of_integer less_integer.rep_eq)
qed
qed
lemma ring_finite_field_ops_integer: "ring_ops (finite_field_ops_integer pp) mod_ring_rel_integer"
by (unfold_locales, auto simp:
finite_field_ops_integer_def
bi_unique_mod_ring_rel_integer
right_total_mod_ring_rel_integer
mod_ring_plus_integer
mod_ring_minus_integer
mod_ring_uminus_integer
mod_ring_mult_integer
mod_ring_eq_integer
mod_ring_0__integer
mod_ring_1__integer
Domainp_mod_ring_rel_integer)
end
end
context prime_field
begin
context fixes pp :: "integer"
assumes *: "p = int_of_integer pp"
begin
lemma mod_ring_normalize_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (λx. if x = 0 then 0 else 1) normalize"
using urel_integer_normalize[OF *] mod_ring_normalize unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast
lemma mod_ring_mod_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (λx y. if y = 0 then x else 0) (mod)"
using urel_integer_mod[OF *] mod_ring_mod unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast
lemma mod_ring_unit_factor_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (λx. x) unit_factor"
using mod_ring_unit_factor unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast
lemma mod_ring_inverse_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (inverse_p_integer pp) inverse"
using urel_integer_inverse[OF *] mod_ring_inverse unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast
lemma mod_ring_divide_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (divide_p_integer pp) (/)"
using mod_ring_inverse_integer mod_ring_mult_integer[OF *]
unfolding divide_p_integer_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
rel_fun_def by blast
lemma finite_field_ops_integer: "field_ops (finite_field_ops_integer pp) mod_ring_rel_integer"
by (unfold_locales, insert ring_finite_field_ops_integer[OF *], auto simp:
ring_ops_def
finite_field_ops_integer_def
mod_ring_divide_integer
mod_ring_inverse_integer
mod_ring_mod_integer
mod_ring_normalize_integer)
end
end
context prime_field
begin
thm
finite_field_ops64
finite_field_ops32
finite_field_ops_integer
finite_field_ops_int
end
context mod_ring_locale
begin
thm
ring_finite_field_ops64
ring_finite_field_ops32
ring_finite_field_ops_integer
ring_finite_field_ops_int
end
no_notation shiftr (infixl ">>" 55)
end
Theory Matrix_Record_Based
subsection ‹Matrix Operations in Fields›
text ‹We use our record based description of a field to perform matrix operations.›
theory Matrix_Record_Based
imports
Jordan_Normal_Form.Gauss_Jordan_Elimination
Jordan_Normal_Form.Gauss_Jordan_IArray_Impl
Arithmetic_Record_Based
begin
definition mat_rel :: "('a ⇒ 'b ⇒ bool) ⇒ 'a mat ⇒ 'b mat ⇒ bool" where
"mat_rel R A B ≡ dim_row A = dim_row B ∧ dim_col A = dim_col B ∧
(∀ i j. i < dim_row B ⟶ j < dim_col B ⟶ R (A $$ (i,j)) (B $$ (i,j)))"
lemma right_total_mat_rel: "right_total R ⟹ right_total (mat_rel R)"
unfolding right_total_def
proof
fix B
assume "∀ y. ∃ x. R x y"
from choice[OF this] obtain f where f: "⋀ x. R (f x) x" by auto
show "∃ A. mat_rel R A B"
by (rule exI[of _ "map_mat f B"], unfold mat_rel_def, auto simp: f)
qed
lemma left_unique_mat_rel: "left_unique R ⟹ left_unique (mat_rel R)"
unfolding left_unique_def mat_rel_def mat_eq_iff by (auto, blast)
lemma right_unique_mat_rel: "right_unique R ⟹ right_unique (mat_rel R)"
unfolding right_unique_def mat_rel_def mat_eq_iff by (auto, blast)
lemma bi_unique_mat_rel: "bi_unique R ⟹ bi_unique (mat_rel R)"
using left_unique_mat_rel[of R] right_unique_mat_rel[of R]
unfolding bi_unique_def left_unique_def right_unique_def by blast
lemma mat_rel_eq: "((R ===> R ===> (=))) (=) (=) ⟹
((mat_rel R ===> mat_rel R ===> (=))) (=) (=)"
unfolding mat_rel_def rel_fun_def mat_eq_iff by (auto, blast+)
definition vec_rel :: "('a ⇒ 'b ⇒ bool) ⇒ 'a vec ⇒ 'b vec ⇒ bool" where
"vec_rel R A B ≡ dim_vec A = dim_vec B ∧ (∀ i. i < dim_vec B ⟶ R (A $ i) (B $ i))"
lemma right_total_vec_rel: "right_total R ⟹ right_total (vec_rel R)"
unfolding right_total_def
proof
fix B
assume "∀ y. ∃ x. R x y"
from choice[OF this] obtain f where f: "⋀ x. R (f x) x" by auto
show "∃ A. vec_rel R A B"
by (rule exI[of _ "map_vec f B"], unfold vec_rel_def, auto simp: f)
qed
lemma left_unique_vec_rel: "left_unique R ⟹ left_unique (vec_rel R)"
unfolding left_unique_def vec_rel_def vec_eq_iff by auto
lemma right_unique_vec_rel: "right_unique R ⟹ right_unique (vec_rel R)"
unfolding right_unique_def vec_rel_def vec_eq_iff by auto
lemma bi_unique_vec_rel: "bi_unique R ⟹ bi_unique (vec_rel R)"
using left_unique_vec_rel[of R] right_unique_vec_rel[of R]
unfolding bi_unique_def left_unique_def right_unique_def by blast
lemma vec_rel_eq: "((R ===> R ===> (=))) (=) (=) ⟹
((vec_rel R ===> vec_rel R ===> (=))) (=) (=)"
unfolding vec_rel_def rel_fun_def vec_eq_iff by (auto, blast+)
lemma multrow_transfer[transfer_rule]: "((R ===> R ===> R) ===> (=) ===> R
===> mat_rel R ===> mat_rel R) mat_multrow_gen mat_multrow_gen"
unfolding mat_rel_def[abs_def] mat_multrow_gen_def[abs_def]
by (intro rel_funI conjI allI impI eq_matI, auto simp: rel_fun_def)
lemma swap_rows_transfer: "mat_rel R A B ⟹ i < dim_row B ⟹ j < dim_row B ⟹
mat_rel R (mat_swaprows i j A) (mat_swaprows i j B)"
unfolding mat_rel_def mat_swaprows_def
by (intro rel_funI conjI allI impI eq_matI, auto)
lemma pivot_positions_gen_transfer: assumes [transfer_rule]: "(R ===> R ===> (=)) (=) (=)"
shows
"(R ===> mat_rel R ===> (=)) pivot_positions_gen pivot_positions_gen"
proof (intro rel_funI, goal_cases)
case (1 ze ze' A A')
note trans[transfer_rule] = 1
from 1 have dim: "dim_row A = dim_row A'" "dim_col A = dim_col A'" unfolding mat_rel_def by auto
obtain i j where id: "i = 0" "j = 0" and ij: "i ≤ dim_row A'" "j ≤ dim_col A'" by auto
have "pivot_positions_main_gen ze A (dim_row A) (dim_col A) i j =
pivot_positions_main_gen ze' A' (dim_row A') (dim_col A') i j"
using ij
proof (induct i j rule: pivot_positions_main_gen.induct[of "dim_row A'" "dim_col A'" A' ze'])
case (1 i j)
note simps[simp] = pivot_positions_main_gen.simps[of _ _ _ _ i j]
show ?case
proof (cases "i < dim_row A' ∧ j < dim_col A'")
case False
with dim show ?thesis by auto
next
case True
hence ij: "i < dim_row A'" "j < dim_col A'" and j: "Suc j ≤ dim_col A'" by auto
note IH = 1(1-2)[OF ij _ _ j]
from ij True trans have [transfer_rule]:"R (A $$ (i,j)) (A' $$ (i,j))"
unfolding mat_rel_def by auto
have eq: "(A $$ (i,j) = ze) = (A' $$ (i,j) = ze')" by transfer_prover
show ?thesis
proof (cases "A' $$ (i,j) = ze'")
case True
from ij have "i ≤ dim_row A'" by auto
note IH = IH(1)[OF True this]
thus ?thesis using True ij dim eq by simp
next
case False
from ij have "Suc i ≤ dim_row A'" by auto
note IH = IH(2)[OF False this]
thus ?thesis using False ij dim eq by simp
qed
qed
qed
thus "pivot_positions_gen ze A = pivot_positions_gen ze' A'"
unfolding pivot_positions_gen_def id .
qed
lemma set_pivot_positions_main_gen:
"set (pivot_positions_main_gen ze A nr nc i j) ⊆ {0 ..< nr} × {0 ..< nc}"
proof (induct i j rule: pivot_positions_main_gen.induct[of nr nc A ze])
case (1 i j)
note [simp] = pivot_positions_main_gen.simps[of _ _ _ _ i j]
from 1 show ?case
by (cases "i < nr ∧ j < nc", auto)
qed
lemma find_base_vectors_transfer: assumes [transfer_rule]: "(R ===> R ===> (=)) (=) (=)"
shows "((R ===> R) ===> R ===> R ===> mat_rel R
===> list_all2 (vec_rel R)) find_base_vectors_gen find_base_vectors_gen"
proof (intro rel_funI, goal_cases)
case (1 um um' ze ze' on on' A A')
note trans[transfer_rule] = 1 pivot_positions_gen_transfer[OF assms]
from 1(4) have dim: "dim_row A = dim_row A'" "dim_col A = dim_col A'" unfolding mat_rel_def by auto
have id: "pivot_positions_gen ze A = pivot_positions_gen ze' A'" by transfer_prover
obtain xs where xs: "map snd (pivot_positions_gen ze' A') = xs" by auto
obtain ys where ys: "[j←[0..<dim_col A'] . j ∉ set xs] = ys" by auto
show "list_all2 (vec_rel R) (find_base_vectors_gen um ze on A)
(find_base_vectors_gen um' ze' on' A')"
unfolding find_base_vectors_gen_def Let_def id xs list_all2_conv_all_nth length_map ys dim
proof (intro conjI[OF refl] allI impI)
fix i
assume i: "i < length ys"
define y where "y = ys ! i"
from i have y: "y < dim_col A'" unfolding y_def ys[symmetric] using nth_mem by fastforce
let ?map = "map_of (map prod.swap (pivot_positions_gen ze' A'))"
{
fix i
assume i: "i < dim_col A'"
and neq: "i ≠ y"
have "R (case ?map i of None ⇒ ze | Some j ⇒ um (A $$ (j, y)))
(case ?map i of None ⇒ ze' | Some j ⇒ um' (A' $$ (j, y)))"
proof (cases "?map i")
case None
with trans(2) show ?thesis by auto
next
case (Some j)
from map_of_SomeD[OF this] have "(j,i) ∈ set (pivot_positions_gen ze' A')" by auto
from subsetD[OF set_pivot_positions_main_gen this[unfolded pivot_positions_gen_def]]
have j: "j < dim_row A'" by auto
with trans(4) y have [transfer_rule]: "R (A $$ (j,y)) (A' $$ (j,y))" unfolding mat_rel_def by auto
show ?thesis unfolding Some by (simp, transfer_prover)
qed
} note main = this
show "vec_rel R (map (non_pivot_base_gen um ze on A (pivot_positions_gen ze' A')) ys ! i)
(map (non_pivot_base_gen um' ze' on' A' (pivot_positions_gen ze' A')) ys ! i)"
unfolding y_def[symmetric] nth_map[OF i]
unfolding non_pivot_base_gen_def Let_def dim vec_rel_def
by (intro conjI allI impI, force, insert main, auto simp: trans(3))
qed
qed
lemma eliminate_entries_gen_transfer: assumes *[transfer_rule]: "(R ===> R ===> R) ad ad'"
"(R ===> R ===> R) mul mul'"
and vs: "⋀ j. j < dim_row B' ⟹ R (vs j) (vs' j)"
and i: "i < dim_row B'"
and B: "mat_rel R B B'"
shows "mat_rel R
(eliminate_entries_gen ad mul vs B i j)
(eliminate_entries_gen ad' mul' vs' B' i j)"
proof -
note BB = B[unfolded mat_rel_def]
show ?thesis unfolding mat_rel_def dim_eliminate_entries_gen
proof (intro conjI impI allI)
fix i' j'
assume ij': "i' < dim_row B'" "j' < dim_col B'"
with BB have ij: "i'< dim_row B" "j' < dim_col B" by auto
have [transfer_rule]: "R (B $$ (i', j')) (B' $$ (i', j'))" using BB ij' by auto
have [transfer_rule]: "R (B $$ (i, j')) (B' $$ (i, j'))" using BB ij' i by auto
have [transfer_rule]: "R (vs i') (vs' i')" using ij' vs[of i'] by auto
show "R (eliminate_entries_gen ad mul vs B i j $$ (i', j'))
(eliminate_entries_gen ad' mul' vs' B' i j $$ (i', j'))"
unfolding eliminate_entries_gen_def index_mat(1)[OF ij] index_mat(1)[OF ij'] split
by transfer_prover
qed (insert BB, auto)
qed
context
fixes ops :: "'i arith_ops_record" (structure)
begin
private abbreviation (input) zero where "zero ≡ arith_ops_record.zero ops"
private abbreviation (input) one where "one ≡ arith_ops_record.one ops"
private abbreviation (input) plus where "plus ≡ arith_ops_record.plus ops"
private abbreviation (input) times where "times ≡ arith_ops_record.times ops"
private abbreviation (input) minus where "minus ≡ arith_ops_record.minus ops"
private abbreviation (input) uminus where "uminus ≡ arith_ops_record.uminus ops"
private abbreviation (input) divide where "divide ≡ arith_ops_record.divide ops"
private abbreviation (input) inverse where "inverse ≡ arith_ops_record.inverse ops"
private abbreviation (input) modulo where "modulo ≡ arith_ops_record.modulo ops"
private abbreviation (input) normalize where "normalize ≡ arith_ops_record.normalize ops"
definition eliminate_entries_gen_zero :: "('a ⇒ 'a ⇒ 'a) ⇒ ('a ⇒ 'a ⇒ 'a) ⇒ 'a ⇒ (integer ⇒ 'a) ⇒ 'a mat ⇒ nat ⇒ nat ⇒ 'a mat" where
"eliminate_entries_gen_zero minu time z v A I J = mat (dim_row A) (dim_col A) (λ (i, j).
if v (integer_of_nat i) ≠ z ∧ i ≠ I then minu (A $$ (i,j)) (time (v (integer_of_nat i)) (A $$ (I,j))) else A $$ (i,j))"
definition eliminate_entries_i where "eliminate_entries_i ≡ eliminate_entries_gen_zero minus times zero"
definition multrow_i where "multrow_i ≡ mat_multrow_gen times"
lemma dim_eliminate_entries_gen_zero[simp]:
"dim_row (eliminate_entries_gen_zero mm tt z v B i as) = dim_row B"
"dim_col (eliminate_entries_gen_zero mm tt z v B i as) = dim_col B"
unfolding eliminate_entries_gen_zero_def by auto
partial_function (tailrec) gauss_jordan_main_i :: "nat ⇒ nat ⇒ 'i mat ⇒ nat ⇒ nat ⇒ 'i mat" where
[code]: "gauss_jordan_main_i nr nc A i j = (
if i < nr ∧ j < nc then let aij = A $$ (i,j) in if aij = zero then
(case [ i' . i' <- [Suc i ..< nr], A $$ (i',j) ≠ zero]
of [] ⇒ gauss_jordan_main_i nr nc A i (Suc j)
| (i' # _) ⇒ gauss_jordan_main_i nr nc (swaprows i i' A) i j)
else if aij = one then let
v = (λ i. A $$ (nat_of_integer i,j)) in
gauss_jordan_main_i nr nc
(eliminate_entries_i v A i j) (Suc i) (Suc j)
else let iaij = inverse aij; A' = multrow_i i iaij A;
v = (λ i. A' $$ (nat_of_integer i,j))
in gauss_jordan_main_i nr nc (eliminate_entries_i v A' i j) (Suc i) (Suc j)
else A)"
definition gauss_jordan_single_i :: "'i mat ⇒ 'i mat" where
"gauss_jordan_single_i A ≡ gauss_jordan_main_i (dim_row A) (dim_col A) A 0 0"
definition find_base_vectors_i :: "'i mat ⇒ 'i vec list" where
"find_base_vectors_i A ≡ find_base_vectors_gen uminus zero one A"
end
context field_ops
begin
lemma right_total_poly_rel[transfer_rule]: "right_total (mat_rel R)"
using right_total_mat_rel[of R] right_total .
lemma bi_unique_poly_rel[transfer_rule]: "bi_unique (mat_rel R)"
using bi_unique_mat_rel[of R] bi_unique .
lemma eq_mat_rel[transfer_rule]: "(mat_rel R ===> mat_rel R ===> (=)) (=) (=)"
by (rule mat_rel_eq[OF eq])
lemma multrow_i[transfer_rule]: "((=) ===> R ===> mat_rel R ===> mat_rel R)
(multrow_i ops) multrow"
using multrow_transfer[of R] times unfolding multrow_i_def rel_fun_def by blast
lemma eliminate_entries_gen_zero[simp]:
assumes "mat_rel R A A'" "I < dim_row A'" shows
"eliminate_entries_gen_zero minus times zero v A I J = eliminate_entries_gen minus times (v o integer_of_nat) A I J"
unfolding eliminate_entries_gen_def eliminate_entries_gen_zero_def
proof(standard,goal_cases)
case (1 i j)
have d1:"DP (A $$ (I, j))" and d2:"DP (A $$ (i, j))" using assms DPR 1
unfolding mat_rel_def dim_col_mat dim_row_mat
by (metis Domainp.DomainI)+
have e1:"⋀ x. (0::'a) * x = 0" and e2:"⋀ x. x - (0::'a) = x" by auto
from e1[untransferred,OF d1] e2[untransferred,OF d2] 1 show ?case by auto
qed auto
lemma eliminate_entries_i: assumes
vs: "⋀ j. j < dim_row B' ⟹ R (vs (integer_of_nat j)) (vs' j)"
and i: "i < dim_row B'"
and B: "mat_rel R B B'"
shows "mat_rel R (eliminate_entries_i ops vs B i j)
(eliminate_entries vs' B' i j)"
unfolding eliminate_entries_i_def eliminate_entries_gen_zero[OF B i]
by (rule eliminate_entries_gen_transfer, insert assms, auto simp: plus times minus)
lemma gauss_jordan_main_i:
"nr = dim_row A' ⟹ nc = dim_col A' ⟹ mat_rel R A A' ⟹ i ≤ nr ⟹ j ≤ nc ⟹
mat_rel R (gauss_jordan_main_i ops nr nc A i j) (fst (gauss_jordan_main A' B' i j))"
proof -
obtain P where P: "P = (A',i,j)" by auto
let ?Rel = "measures [λ (A' :: 'a mat,i,j). nc - j, λ (A',i,j). if A' $$ (i,j) = 0 then 1 else 0]"
have wf: "wf ?Rel" by simp
show "nr = dim_row A' ⟹ nc = dim_col A' ⟹ mat_rel R A A' ⟹ i ≤ nr ⟹ j ≤ nc ⟹
mat_rel R (gauss_jordan_main_i ops nr nc A i j) (fst (gauss_jordan_main A' B' i j))"
using P
proof (induct P arbitrary: A' B' A i j rule: wf_induct[OF wf])
case (1 P A' B' A i j)
note prems = 1(2-6)
note P = 1(7)
note A[transfer_rule] = prems(3)
note IH = 1(1)[rule_format, OF _ _ _ _ _ _ refl]
note simps = gauss_jordan_main_code[of A' B' i j, unfolded Let_def, folded prems(1-2)]
gauss_jordan_main_i.simps[of ops nr nc A i j] Let_def if_True if_False
show ?case
proof (cases "i < nr ∧ j < nc")
case False
hence id: "(i < nr ∧ j < nc) = False" by simp
show ?thesis unfolding simps id by simp transfer_prover
next
case True note ij' = this
hence id: "(i < nr ∧ j < nc) = True" "⋀ x y z. (if x = x then y else z) = y" by auto
from True prems have ij [transfer_rule]:"R (A $$ (i,j)) (A' $$ (i,j))"
unfolding mat_rel_def by auto
from True prems have i: "i < dim_row A'" "j < dim_col A'" and i': "i < nr" "j < nc" by auto
{
fix i
assume "i < dim_row A'"
with i True prems have R[transfer_rule]:"R (A $$ (i,j)) (A' $$ (i,j))"
unfolding mat_rel_def by auto
have "(A $$ (i,j) = zero) = (A' $$ (i,j) = 0)" by transfer_prover
note this R
} note eq_gen = this
have eq: "(A $$ (i,j) = zero) = (A' $$ (i,j) = 0)"
"(A $$ (i,j) = one) = (A' $$ (i,j) = 1)"
by transfer_prover+
show ?thesis
proof (cases "A' $$ (i, j) = 0")
case True
hence eq: "A $$ (i,j) = zero" using eq by auto
let ?is = "[ i' . i' <- [Suc i ..< nr], A $$ (i',j) ≠ zero]"
let ?is' = "[ i' . i' <- [Suc i ..< nr], A' $$ (i',j) ≠ 0]"
define xs where "xs = [Suc i..<nr]"
have xs: "set xs ⊆ {0 ..< dim_row A'}" unfolding xs_def using prems by auto
hence id': "?is = ?is'" unfolding xs_def[symmetric]
by (induct xs, insert eq_gen, auto)
show ?thesis
proof (cases ?is')
case Nil
have "?thesis = (mat_rel R (gauss_jordan_main_i ops nr nc A i (Suc j))
(fst (gauss_jordan_main A' B' i (Suc j))))"
unfolding True simps id eq unfolding Nil id'[unfolded Nil] by simp
also have "…"
by (rule IH, insert i prems P, auto)
finally show ?thesis .
next
case (Cons i' idx')
from arg_cong[OF this, of set] i
have i': "i' < nr" "A' $$ (i', j) ≠ 0" by auto
with ij' prems(1-2) have *: "i' < dim_row A'" "i < dim_row A'" "j < dim_col A'" by auto
have rel: "((swaprows i i' A', i, j), P) ∈ ?Rel"
by (simp add: P True * i')
have "?thesis = (mat_rel R (gauss_jordan_main_i ops nr nc (swaprows i i' A) i j)
(fst (gauss_jordan_main (swaprows i i' A') (swaprows i i' B') i j)))"
unfolding True simps id eq Cons id'[unfolded Cons] by simp
also have "…"
by (rule IH[OF rel _ _ swap_rows_transfer], insert i i' prems P True, auto)
finally show ?thesis .
qed
next
case False
from False eq have neq: "(A $$ (i, j) = zero) = False" "(A' $$ (i, j) = 0) = False" by auto
{
fix B B' i
assume B[transfer_rule]: "mat_rel R B B'" and dim: "dim_col B' = nc" and i: "i < dim_row B'"
from dim i True have "j < dim_col B'" by simp
with B i have "R (B $$ (i,j)) (B' $$ (i,j))"
by (simp add: mat_rel_def)
} note vec_rel = this
from prems have dim: "dim_row A = dim_row A'" unfolding mat_rel_def by auto
show ?thesis
proof (cases "A' $$ (i, j) = 1")
case True
from True eq have eq: "(A $$ (i,j) = one) = True" "(A' $$ (i,j) = 1) = True" by auto
note rel = vec_rel[OF A]
show ?thesis unfolding simps id neq eq
by (rule IH[OF _ _ _ eliminate_entries_i], insert rel prems ij i P dim, auto)
next
case False
from False eq have eq: "(A $$ (i,j) = one) = False" "(A' $$ (i,j) = 1) = False" by auto
show ?thesis unfolding simps id neq eq
proof (rule IH, goal_cases)
case 4
have A': "mat_rel R (multrow_i ops i (inverse (A $$ (i, j))) A)
(multrow i (inverse_class.inverse (A' $$ (i, j))) A')" by transfer_prover
note rel = vec_rel[OF A']
show ?case
by (rule eliminate_entries_i[OF _ _ A'], insert rel prems i dim, auto)
qed (insert prems i P, auto)
qed
qed
qed
qed
qed
lemma gauss_jordan_i[transfer_rule]:
"(mat_rel R ===> mat_rel R) (gauss_jordan_single_i ops) gauss_jordan_single"
proof (intro rel_funI)
fix A A'
assume A: "mat_rel R A A'"
show "mat_rel R (gauss_jordan_single_i ops A) (gauss_jordan_single A')"
unfolding gauss_jordan_single_def gauss_jordan_single_i_def gauss_jordan_def
by (rule gauss_jordan_main_i[OF _ _ A], insert A, auto simp: mat_rel_def)
qed
lemma find_base_vectors_i[transfer_rule]:
"(mat_rel R ===> list_all2 (vec_rel R)) (find_base_vectors_i ops) find_base_vectors"
unfolding find_base_vectors_i_def[abs_def]
using find_base_vectors_transfer[OF eq] uminus zero one
unfolding rel_fun_def by blast
end
lemma list_of_vec_transfer[transfer_rule]: "(vec_rel A ===> list_all2 A) list_of_vec list_of_vec"
unfolding rel_fun_def vec_rel_def vec_eq_iff list_all2_conv_all_nth
by auto
lemma IArray_sub'[simp]: "i < IArray.length a ⟹ IArray.sub' (a, integer_of_nat i) = IArray.sub a i"
by auto
lift_definition eliminate_entries_i2 ::
"'a ⇒ ('a ⇒ 'a ⇒ 'a) ⇒ ('a ⇒ 'a ⇒ 'a) ⇒ (integer ⇒ 'a) ⇒ 'a mat_impl ⇒ integer ⇒ 'a mat_impl" is
"λ z mminus ttimes v (nr, nc, a) i'.
(nr,nc,let ai' = IArray.sub' (a, i') in (IArray.tabulate (integer_of_nat nr, λ i. let ai = IArray.sub' (a, i) in
if i = i' then ai else
let vi'j = v i
in if vi'j = z then ai
else
IArray.tabulate (integer_of_nat nc, λ j. mminus (IArray.sub' (ai, j)) (ttimes vi'j
(IArray.sub' (ai', j))))
)))"
proof(goal_cases)
case (1 z mm tt vec prod nat2)
thus ?case by(cases prod;cases "snd (snd prod)";auto simp:Let_def)
qed
lemma eliminate_entries_gen_zero [simp]:
assumes "i<(dim_row A)" "j<(dim_col A)" shows
"eliminate_entries_gen_zero mminus ttimes z v A I J $$ (i, j) =
(if v (integer_of_nat i) = z ∨ i = I then A $$ (i,j) else mminus (A $$ (i,j)) (ttimes (v (integer_of_nat i)) (A $$ (I,j))))"
using assms unfolding eliminate_entries_gen_zero_def by auto
lemma eliminate_entries_gen [simp]:
assumes "i<(dim_row A)" "j<(dim_col A)" shows
"eliminate_entries_gen mminus ttimes v A I J $$ (i, j) =
(if i = I then A $$ (i,j) else mminus (A $$ (i,j)) (ttimes (v i) (A $$ (I,j))))"
using assms unfolding eliminate_entries_gen_def by auto
lemma dim_mat_impl [simp]:
"dim_row (mat_impl x) = dim_row_impl x"
"dim_col (mat_impl x) = dim_col_impl x"
by (cases "Rep_mat_impl x";auto simp:mat_impl.rep_eq dim_row_def dim_col_def dim_row_impl.rep_eq dim_col_impl.rep_eq)+
lemma dim_eliminate_entries_i2 [simp]:
"dim_row_impl (eliminate_entries_i2 z mm tt v m i) = dim_row_impl m"
"dim_col_impl (eliminate_entries_i2 z mm tt v m i) = dim_col_impl m"
by (transfer, auto)+
lemma tabulate_nth: "i < n ⟹ IArray.tabulate (integer_of_nat n, f) !! i = f (integer_of_nat i)"
using of_fun_nth[of i n] by auto
lemma eliminate_entries_i2[code]:"eliminate_entries_gen_zero mm tt z v (mat_impl m) i j
= (if i < dim_row_impl m
then mat_impl (eliminate_entries_i2 z mm tt v m (integer_of_nat i))
else (Code.abort (STR ''index out of range in eliminate_entries'')
(λ _. eliminate_entries_gen_zero mm tt z v (mat_impl m) i j)))"
proof (cases "i < dim_row_impl m")
case True
hence id: "(i < dim_row_impl m) = True" by simp
show ?thesis unfolding id if_True
proof (standard;goal_cases)
case (1 i j)
have dims: "i < dim_row (mat_impl m)" "j < dim_col (mat_impl m)" using 1 by (auto simp:eliminate_entries_i2.rep_eq)
then show ?case unfolding eliminate_entries_gen_zero[OF dims] using True
proof(transfer, goal_cases)
case (1 i m j ia v z mm tt)
obtain nr nc M where m: "m = (nr,nc,M)" by (cases m)
note 1 = 1[unfolded m, simplified]
have mk: "⋀ f. mk_mat nr nc f (i,j) = f (i,j)"
"⋀ f. mk_mat nr nc f (ia,j) = f (ia,j)"
using 1 unfolding mk_mat_def mk_vec_def by auto
note of_fun = of_fun_nth[OF 1(2)] of_fun_nth[OF 1(3)] tabulate_nth[OF 1(2)] tabulate_nth[OF 1(3)]
let ?c1 = "v (integer_of_nat i) = z"
show ?case
proof (cases "?c1 ∨ i = ia")
case True
hence id: "(if ?c1 ∨ i = ia then x else y) = x"
"(if integer_of_nat i = integer_of_nat ia then x else if ?c1 then x else y) = x" for x y
by auto
show ?thesis unfolding id m o_def Let_def split snd_conv mk of_fun by (auto simp: 1)
next
case False
hence id: "?c1 = False " "(integer_of_nat i = integer_of_nat ia) = False" "(False ∨ i = ia) = False"
by (auto simp add: integer_of_nat_eq_of_nat)
show ?thesis unfolding m o_def Let_def split snd_conv mk of_fun id if_False
by (auto simp: 1)
qed
qed
qed (auto simp:eliminate_entries_i2.rep_eq)
qed auto
end
Theory Missing_Multiset2
theory Missing_Multiset2
imports "HOL-Library.Multiset" "HOL-Library.Permutation" "HOL-Library.Permutations"
Containers.Containers_Auxiliary
begin
subsubsection ‹Missing muiltiset›
lemma id_imp_bij:
assumes id: "⋀x. f (f x) = x" shows "bij f"
proof (intro bijI injI surjI[of f, OF id])
fix x y assume "f x = f y"
then have "f (f x) = f (f y)" by auto
with id show "x = y" by auto
qed
lemma rel_mset_Zero_iff[simp]:
shows "rel_mset rel {#} Y ⟷ Y = {#}" and "rel_mset rel X {#} ⟷ X = {#}"
using rel_mset_Zero rel_mset_size by (fastforce, fastforce)
definition "is_mset_set X ≡ ∀x ∈# X. count X x = 1"
lemma is_mset_setD[dest]: "is_mset_set X ⟹ x ∈# X ⟹ count X x = 1"
unfolding is_mset_set_def by auto
lemma is_mset_setI[intro]:
assumes "⋀x. x ∈# X ⟹ count X x = 1"
shows "is_mset_set X"
using assms unfolding is_mset_set_def by auto
lemma is_mset_set[simp]: "is_mset_set (mset_set X)"
unfolding is_mset_set_def
by (meson count_mset_set(1) count_mset_set(2) count_mset_set(3) not_in_iff)
lemma is_mset_set_add[simp]:
"is_mset_set (X + {#x#}) ⟷ is_mset_set X ∧ x ∉# X" (is "?L ⟷ ?R")
proof(intro iffI conjI)
assume L: ?L
with count_eq_zero_iff count_single show "is_mset_set X"
unfolding is_mset_set_def
by (metis (no_types, hide_lams) add_mset_add_single count_add_mset nat.inject set_mset_add_mset_insert union_single_eq_member)
show "x ∉# X"
proof
assume "x ∈# X"
then have "count (X + {#x#}) x > 1" by auto
with L show False by (auto simp: is_mset_set_def)
qed
next
assume R: ?R show ?L
proof
fix x' assume x': "x' ∈# X + {#x#}"
show "count (X + {#x#}) x' = 1"
proof(cases "x' ∈# X")
case True with R have "count X x' = 1" by auto
moreover from True R have "count {#x#} x' = 0" by auto
ultimately show ?thesis by auto
next
case False then have "count X x' = 0" by (simp add: not_in_iff)
with R x' show ?thesis by auto
qed
qed
qed
lemma mset_set_id[simp]:
assumes "is_mset_set X"
shows "mset_set (set_mset X) = X"
using assms unfolding is_mset_set_def
by (metis count_eq_zero_iff count_mset_set(1) count_mset_set(3) finite_set_mset multiset_eqI)
lemma count_image_mset:
shows "count (image_mset f X) y = (∑x | x ∈# X ∧ y = f x. count X x)"
proof(induct X)
case empty show ?case by auto
next
case (add x X)
define X' where "X' ≡ X + {#x#}"
have "(∑z | z ∈# X' ∧ y = f z. count (X + {#x#}) z) =
(∑z | z ∈# X' ∧ y = f z. count X z) + (∑z | z ∈# X' ∧ y = f z. count {#x#} z)"
unfolding plus_multiset.rep_eq sum.distrib..
also have split:
"{z. z ∈# X' ∧ y = f z} =
{z. z ∈# X' ∧ y = f z ∧ z ≠ x} ∪ {z. z ∈# X' ∧ y = f z ∧ z = x}" by blast
then have "(∑z | z ∈# X' ∧ y = f z. count {#x#} z) =
(∑z | z ∈# X' ∧ y = f z ∧ z = x. count {#x#} z)"
unfolding split by (subst sum.union_disjoint, auto)
also have "... = (if y = f x then 1 else 0)" using card_eq_Suc_0_ex1 by (auto simp: X'_def)
also have "(∑z | z ∈# X' ∧ y = f z. count X z) = (∑z | z ∈# X ∧ y = f z. count X z)"
proof(cases "x ∈# X")
case True then have "z ∈# X' ⟷ z ∈# X" for z by (auto simp: X'_def)
then show ?thesis by auto
next
case False
have split: "{z. z ∈# X' ∧ y = f z} = {z. z ∈# X ∧ y = f z} ∪ {z. z = x ∧ y = f z}"
by (auto simp: X'_def)
also have "sum (count X) ... = (∑z | z ∈# X ∧ y = f z. count X z) + (∑z | z = x ∧ y = f z. count X z)"
by (subst sum.union_disjoint, auto simp: False)
also with False have "⋀z. z = x ∧ y = f z ⟹ count X z = 0" by (meson count_inI)
with sum.neutral_const have "(∑z | z = x ∧ y = f z. count X z) = 0" by auto
finally show ?thesis by auto
qed
also have "... = count (image_mset f X) y" using add by auto
finally show ?case by (simp add: X'_def)
qed
lemma is_mset_set_image:
assumes "inj_on f (set_mset X)" and "is_mset_set X"
shows "is_mset_set (image_mset f X)"
proof (cases X)
case empty then show ?thesis by auto
next
case (add x X)
define X' where "X' ≡ add_mset x X"
with assms add have inj:"inj_on f (set_mset X')"
and X': "is_mset_set X'" by auto
show ?thesis
proof(unfold add, intro is_mset_setI, fold X'_def)
fix y assume "y ∈# image_mset f X'"
then have "y ∈ f ` set_mset X'" by auto
with inj have "∃!x'. x' ∈# X' ∧ y = f x'" by (meson imageE inj_onD)
then obtain x' where x': "{x'. x' ∈# X' ∧ y = f x'} = {x'}" by auto
then have "count (image_mset f X') y = count X' x'"
unfolding count_image_mset by auto
also from X' x' have "... = 1" by auto
finally show "count (image_mset f X') y = 1".
qed
qed
lemma ex_mset_zip_right:
assumes "length xs = length ys" "mset ys' = mset ys"
shows "∃xs'. length ys' = length xs' ∧ mset (zip xs' ys') = mset (zip xs ys)"
using assms
proof (induct xs ys arbitrary: ys' rule: list_induct2)
case Nil
thus ?case
by auto
next
case (Cons x xs y ys ys')
obtain j where j_len: "j < length ys'" and nth_j: "ys' ! j = y"
by (metis Cons.prems in_set_conv_nth list.set_intros(1) mset_eq_setD)
define ysa where "ysa = take j ys' @ drop (Suc j) ys'"
have "mset ys' = {#y#} + mset ysa"
unfolding ysa_def using j_len nth_j
by (metis Cons_nth_drop_Suc union_mset_add_mset_right add_mset_remove_trivial add_diff_cancel_left'
append_take_drop_id mset.simps(2) mset_append)
hence ms_y: "mset ysa = mset ys"
by (simp add: Cons.prems)
then obtain xsa where
len_a: "length ysa = length xsa" and ms_a: "mset (zip xsa ysa) = mset (zip xs ys)"
using Cons.hyps(2) by blast
define xs' where "xs' = take j xsa @ x # drop j xsa"
have ys': "ys' = take j ysa @ y # drop j ysa"
using ms_y j_len nth_j Cons.prems ysa_def
by (metis append_eq_append_conv append_take_drop_id diff_Suc_Suc Cons_nth_drop_Suc length_Cons
length_drop size_mset)
have j_len': "j ≤ length ysa"
using j_len ys' ysa_def
by (metis add_Suc_right append_take_drop_id length_Cons length_append less_eq_Suc_le not_less)
have "length ys' = length xs'"
unfolding xs'_def using Cons.prems len_a ms_y
by (metis add_Suc_right append_take_drop_id length_Cons length_append mset_eq_length)
moreover have "mset (zip xs' ys') = mset (zip (x # xs) (y # ys))"
unfolding ys' xs'_def
apply (rule HOL.trans[OF mset_zip_take_Cons_drop_twice])
using j_len' by (auto simp: len_a ms_a)
ultimately show ?case
by blast
qed
lemma list_all2_reorder_right_invariance:
assumes rel: "list_all2 R xs ys" and ms_y: "mset ys' = mset ys"
shows "∃xs'. list_all2 R xs' ys' ∧ mset xs' = mset xs"
proof -
have len: "length xs = length ys"
using rel list_all2_conv_all_nth by auto
obtain xs' where
len': "length xs' = length ys'" and ms_xy: "mset (zip xs' ys') = mset (zip xs ys)"
using len ms_y by (metis ex_mset_zip_right)
have "list_all2 R xs' ys'"
using assms(1) len' ms_xy unfolding list_all2_iff by (blast dest: mset_eq_setD)
moreover have "mset xs' = mset xs"
using len len' ms_xy map_fst_zip mset_map by metis
ultimately show ?thesis
by blast
qed
lemma rel_mset_via_perm: "rel_mset rel (mset xs) (mset ys) ⟷ (∃zs. perm xs zs ∧ list_all2 rel zs ys)"
proof (unfold rel_mset_def, intro iffI, goal_cases)
case 1
then obtain zs ws where zs: "mset zs = mset xs" and ws: "mset ws = mset ys" and zsws: "list_all2 rel zs ws" by auto
note list_all2_reorder_right_invariance[OF zsws ws[symmetric], unfolded zs mset_eq_perm]
then show ?case using perm_sym by auto
next
case 2
from this[folded mset_eq_perm] show ?case by force
qed
lemma rel_mset_free:
assumes rel: "rel_mset rel X Y" and xs: "mset xs = X"
shows "∃ys. mset ys = Y ∧ list_all2 rel xs ys"
proof-
from rel[unfolded rel_mset_def] obtain xs' ys'
where xs': "mset xs' = X" and ys': "mset ys' = Y" and xsys': "list_all2 rel xs' ys'" by auto
from xs' xs have "mset xs = mset xs'" by auto
from mset_eq_permutation[OF this]
obtain f where perm: "f permutes {..<length xs'}" and xs': "permute_list f xs' = xs".
then have [simp]: "length xs' = length xs" by auto
from permute_list_nth[OF perm, unfolded xs'] have *: "⋀i. i < length xs ⟹ xs ! i = xs' ! f i" by auto
note [simp] = list_all2_lengthD[OF xsys',symmetric]
note [simp] = atLeast0LessThan[symmetric]
note bij = permutes_bij[OF perm]
define ys where "ys ≡ map (nth ys' ∘ f) [0..<length ys']"
then have [simp]: "length ys = length ys'" by auto
have "mset ys = mset (map (nth ys') (map f [0..<length ys']))"
unfolding ys_def by auto
also have "... = image_mset (nth ys') (image_mset f (mset [0..<length ys']))"
by (simp add: multiset.map_comp)
also have "(mset [0..<length ys']) = mset_set {0..<length ys'}"
by (metis mset_sorted_list_of_multiset sorted_list_of_mset_set sorted_list_of_set_range)
also have "image_mset f (...) = mset_set (f ` {..<length ys'})"
using subset_inj_on[OF bij_is_inj[OF bij]] by (subst image_mset_mset_set, auto)
also have "... = mset [0..<length ys']" using perm by (simp add: permutes_image)
also have "image_mset (nth ys') ... = mset ys'" by(fold mset_map, unfold map_nth, auto)
finally have "mset ys = Y" using ys' by auto
moreover have "list_all2 rel xs ys"
proof(rule list_all2_all_nthI)
fix i assume i: "i < length xs"
with * have "xs ! i = xs' ! f i" by auto
also from i permutes_in_image[OF perm]
have "rel (xs' ! f i) (ys' ! f i)" by (intro list_all2_nthD[OF xsys'], auto)
finally show "rel (xs ! i) (ys ! i)" unfolding ys_def using i by simp
qed simp
ultimately show ?thesis by auto
qed
lemma rel_mset_split:
assumes rel: "rel_mset rel (X1+X2) Y"
shows "∃Y1 Y2. Y = Y1 + Y2 ∧ rel_mset rel X1 Y1 ∧ rel_mset rel X2 Y2"
proof-
obtain xs1 where xs1: "mset xs1 = X1" using ex_mset by auto
obtain xs2 where xs2: "mset xs2 = X2" using ex_mset by auto
from xs1 xs2 have "mset (xs1 @ xs2) = X1 + X2" by auto
from rel_mset_free[OF rel this] obtain ys
where ys: "mset ys = Y" "list_all2 rel (xs1 @ xs2) ys" by auto
then obtain ys1 ys2
where ys12: "ys = ys1 @ ys2"
and xs1ys1: "list_all2 rel xs1 ys1"
and xs2ys2: "list_all2 rel xs2 ys2"
using list_all2_append1 by blast
from ys12 ys have "Y = mset ys1 + mset ys2" by auto
moreover from xs1 xs1ys1 have "rel_mset rel X1 (mset ys1)" unfolding rel_mset_def by auto
moreover from xs2 xs2ys2 have "rel_mset rel X2 (mset ys2)" unfolding rel_mset_def by auto
ultimately show ?thesis by (subst exI[of _ "mset ys1"], subst exI[of _ "mset ys2"],auto)
qed
lemma rel_mset_OO:
assumes AB: "rel_mset R A B" and BC: "rel_mset S B C"
shows "rel_mset (R OO S) A C"
proof-
from AB obtain as bs where A_as: "A = mset as" and B_bs: "B = mset bs" and as_bs: "list_all2 R as bs"
by (auto simp: rel_mset_def)
from rel_mset_free[OF BC] B_bs obtain cs where C_cs: "C = mset cs" and bs_cs: "list_all2 S bs cs"
by auto
from list_all2_trans[OF _ as_bs bs_cs, of "R OO S"] A_as C_cs
show ?thesis by (auto simp: rel_mset_def)
qed
end
Theory Unique_Factorization
theory Unique_Factorization
imports
Polynomial_Interpolation.Ring_Hom_Poly
Polynomial_Factorization.Polynomial_Divisibility
"HOL-Library.Permutations"
"HOL-Computational_Algebra.Euclidean_Algorithm"
Containers.Containers_Auxiliary
Missing_Multiset2
"HOL-Algebra.Divisibility"
begin
hide_const(open)
Divisibility.prime
Divisibility.irreducible
hide_fact(open)
Divisibility.irreducible_def
Divisibility.irreducibleI
Divisibility.irreducibleD
Divisibility.irreducibleE
hide_const (open) Rings.coprime
lemma irreducible_uminus [simp]:
fixes a::"'a::idom"
shows "irreducible (-a) ⟷ irreducible a"
using irreducible_mult_unit_left[of "-1::'a"] by auto
context comm_monoid_mult begin
definition coprime :: "'a ⇒ 'a ⇒ bool"
where coprime_def': "coprime p q ≡ ∀r. r dvd p ⟶ r dvd q ⟶ r dvd 1"
lemma coprimeI:
assumes "⋀r. r dvd p ⟹ r dvd q ⟹ r dvd 1"
shows "coprime p q" using assms by (auto simp: coprime_def')
lemma coprimeE:
assumes "coprime p q"
and "(⋀r. r dvd p ⟹ r dvd q ⟹ r dvd 1) ⟹ thesis"
shows thesis using assms by (auto simp: coprime_def')
lemma coprime_commute [ac_simps]:
"coprime p q ⟷ coprime q p"
by (auto simp add: coprime_def')
lemma not_coprime_iff_common_factor:
"¬ coprime p q ⟷ (∃r. r dvd p ∧ r dvd q ∧ ¬ r dvd 1)"
by (auto simp add: coprime_def')
end
lemma (in algebraic_semidom) coprime_iff_coprime [simp, code]:
"coprime = Rings.coprime"
by (simp add: fun_eq_iff coprime_def coprime_def')
lemma (in comm_semiring_1) coprime_0 [simp]:
"coprime p 0 ⟷ p dvd 1" "coprime 0 p ⟷ p dvd 1"
by (auto intro: coprimeI elim: coprimeE dest: dvd_trans)
lemma dvd_rewrites: "dvd.dvd ((*)) = (dvd)" by (unfold dvd.dvd_def dvd_def, rule)
subsection ‹Interfacing UFD properties›
hide_const (open) Divisibility.irreducible
context comm_monoid_mult_isom begin
lemma coprime_hom[simp]: "coprime (hom x) y' ⟷ coprime x (Hilbert_Choice.inv hom y')"
proof-
show ?thesis by (unfold coprime_def', fold ball_UNIV, subst surj[symmetric], simp)
qed
lemma coprime_inv_hom[simp]: "coprime (Hilbert_Choice.inv hom x') y ⟷ coprime x' (hom y)"
proof-
interpret inv: comm_monoid_mult_isom "Hilbert_Choice.inv hom"..
show ?thesis by simp
qed
end
subsubsection ‹Original part›
lemma dvd_dvd_imp_smult:
fixes p q :: "'a :: idom poly"
assumes pq: "p dvd q" and qp: "q dvd p" shows "∃c. p = smult c q"
proof (cases "p = 0")
case True then show ?thesis by auto
next
case False
from qp obtain r where r: "p = q * r" by (elim dvdE, auto)
with False qp have r0: "r ≠ 0" and q0: "q ≠ 0" by auto
with divides_degree[OF pq] divides_degree[OF qp] False
have "degree p = degree q" by auto
with r degree_mult_eq[OF q0 r0] have "degree r = 0" by auto
from degree_0_id[OF this] obtain c where "r = [:c:]" by metis
from r[unfolded this] show ?thesis by auto
qed
lemma dvd_const:
assumes pq: "(p::'a::semidom poly) dvd q" and q0: "q ≠ 0" and degq: "degree q = 0"
shows "degree p = 0"
proof-
from dvdE[OF pq] obtain r where *: "q = p * r".
with q0 have "p ≠ 0" "r ≠ 0" by auto
from degree_mult_eq[OF this] degq * show "degree p = 0" by auto
qed
context Rings.dvd begin
abbreviation ddvd (infix "ddvd" 40) where "x ddvd y ≡ x dvd y ∧ y dvd x"
lemma ddvd_sym[sym]: "x ddvd y ⟹ y ddvd x" by auto
end
context comm_monoid_mult begin
lemma ddvd_trans[trans]: "x ddvd y ⟹ y ddvd z ⟹ x ddvd z" using dvd_trans by auto
lemma ddvd_transp: "transp (ddvd)" by (intro transpI, fact ddvd_trans)
end
context comm_semiring_1 begin
definition mset_factors where "mset_factors F p ≡
F ≠ {#} ∧ (∀f. f ∈# F ⟶ irreducible f) ∧ p = prod_mset F"
lemma mset_factorsI[intro!]:
assumes "⋀f. f ∈# F ⟹ irreducible f" and "F ≠ {#}" and "prod_mset F = p"
shows "mset_factors F p"
unfolding mset_factors_def using assms by auto
lemma mset_factorsD:
assumes "mset_factors F p"
shows "f ∈# F ⟹ irreducible f" and "F ≠ {#}" and "prod_mset F = p"
using assms[unfolded mset_factors_def] by auto
lemma mset_factorsE[elim]:
assumes "mset_factors F p"
and "(⋀f. f ∈# F ⟹ irreducible f) ⟹ F ≠ {#} ⟹ prod_mset F = p ⟹ thesis"
shows thesis
using assms[unfolded mset_factors_def] by auto
lemma mset_factors_imp_not_is_unit:
assumes "mset_factors F p"
shows "¬ p dvd 1"
proof(cases F)
case empty with assms show ?thesis by auto
next
case (add f F)
with assms have "¬ f dvd 1" "p = f * prod_mset F" by (auto intro!: irreducible_not_unit)
then show ?thesis by auto
qed
definition primitive_poly where "primitive_poly f ≡ ∀d. (∀i. d dvd coeff f i) ⟶ d dvd 1"
end
lemma(in semidom) mset_factors_imp_nonzero:
assumes "mset_factors F p"
shows "p ≠ 0"
proof
assume "p = 0"
moreover from assms have "prod_mset F = p" by auto
ultimately obtain f where "f ∈# F" "f = 0" by auto
with assms show False by auto
qed
class ufd = idom +
assumes mset_factors_exist: "⋀x. x ≠ 0 ⟹ ¬ x dvd 1 ⟹ ∃F. mset_factors F x"
and mset_factors_unique: "⋀x F G. mset_factors F x ⟹ mset_factors G x ⟹ rel_mset (ddvd) F G"
subsubsection ‹Connecting to HOL/Divisibility›
context comm_semiring_1 begin
abbreviation "mk_monoid ≡ ⦇carrier = UNIV - {0}, mult = (*), one = 1⦈"
lemma carrier_0[simp]: "x ∈ carrier mk_monoid ⟷ x ≠ 0" by auto
lemmas mk_monoid_simps = carrier_0 monoid.simps
abbreviation irred where "irred ≡ Divisibility.irreducible mk_monoid"
abbreviation factor where "factor ≡ Divisibility.factor mk_monoid"
abbreviation factors where "factors ≡ Divisibility.factors mk_monoid"
abbreviation properfactor where "properfactor ≡ Divisibility.properfactor mk_monoid"
lemma factors: "factors fs y ⟷ prod_list fs = y ∧ Ball (set fs) irred"
proof -
have "prod_list fs = foldr (*) fs 1" by (induct fs, auto)
thus ?thesis unfolding factors_def by auto
qed
lemma factor: "factor x y ⟷ (∃z. z ≠ 0 ∧ x * z = y)" unfolding factor_def by auto
lemma properfactor_nz:
shows "(y :: 'a) ≠ 0 ⟹ properfactor x y ⟷ x dvd y ∧ ¬ y dvd x"
by (auto simp: properfactor_def factor_def dvd_def)
lemma mem_Units[simp]: "y ∈ Units mk_monoid ⟷ y dvd 1"
unfolding dvd_def Units_def by (auto simp: ac_simps)
end
context idom begin
lemma irred_0[simp]: "irred (0::'a)" by (unfold Divisibility.irreducible_def, auto simp: factor properfactor_def)
lemma factor_idom[simp]: "factor (x::'a) y ⟷ (if y = 0 then x = 0 else x dvd y)"
by (cases "y = 0"; auto intro: exI[of _ 1] elim: dvdE simp: factor)
lemma associated_connect[simp]: "(∼⇘mk_monoid⇙) = (ddvd)" by (intro ext, unfold associated_def, auto)
lemma essentially_equal_connect[simp]:
"essentially_equal mk_monoid fs gs ⟷ rel_mset (ddvd) (mset fs) (mset gs)"
by (auto simp: essentially_equal_def rel_mset_via_perm)
lemma irred_idom_nz:
assumes x0: "(x::'a) ≠ 0"
shows "irred x ⟷ irreducible x"
using x0 by (auto simp: irreducible_altdef Divisibility.irreducible_def properfactor_nz)
lemma dvd_dvd_imp_unit_mult:
assumes xy: "x dvd y" and yx: "y dvd x"
shows "∃z. z dvd 1 ∧ y = x * z"
proof(cases "x = 0")
case True with xy show ?thesis by (auto intro: exI[of _ 1])
next
case x0: False
from xy obtain z where z: "y = x * z" by (elim dvdE, auto)
from yx obtain w where w: "x = y * w" by (elim dvdE, auto)
from z w have "x * (z * w) = x" by (auto simp: ac_simps)
then have "z * w = 1" using x0 by auto
with z show ?thesis by (auto intro: exI[of _ z])
qed
lemma irred_inner_nz:
assumes x0: "x ≠ 0"
shows "(∀b. b dvd x ⟶ ¬ x dvd b ⟶ b dvd 1) ⟷ (∀a b. x = a * b ⟶ a dvd 1 ∨ b dvd 1)" (is "?l ⟷ ?r")
proof (intro iffI allI impI)
assume l: ?l
fix a b
assume xab: "x = a * b"
then have ax: "a dvd x" and bx: "b dvd x" by auto
{ assume a1: "¬ a dvd 1"
with l ax have xa: "x dvd a" by auto
from dvd_dvd_imp_unit_mult[OF ax xa] obtain z where z1: "z dvd 1" and xaz: "x = a * z" by auto
from xab x0 have "a ≠ 0" by auto
with xab xaz have "b = z" by auto
with z1 have "b dvd 1" by auto
}
then show "a dvd 1 ∨ b dvd 1" by auto
next
assume r: ?r
fix b assume bx: "b dvd x" and xb: "¬ x dvd b"
then obtain a where xab: "x = a * b" by (elim dvdE, auto simp: ac_simps)
with r consider "a dvd 1" | "b dvd 1" by auto
then show "b dvd 1"
proof(cases)
case 2 then show ?thesis by auto
next
case 1
then obtain c where ac1: "a * c = 1" by (elim dvdE, auto)
from xab have "x * c = b * (a * c)" by (auto simp: ac_simps)
with ac1 have "x * c = b" by auto
then have "x dvd b" by auto
with xb show ?thesis by auto
qed
qed
lemma irred_idom[simp]: "irred x ⟷ x = 0 ∨ irreducible x"
by (cases "x = 0"; simp add: irred_idom_nz irred_inner_nz irreducible_def)
lemma assumes "x ≠ 0" and "factors fs x" and "f ∈ set fs" shows "f ≠ 0"
using assms by (auto simp: factors)
lemma factors_as_mset_factors:
assumes x0: "x ≠ 0" and x1: "x ≠ 1"
shows "factors fs x ⟷ mset_factors (mset fs) x" using assms
by (auto simp: factors prod_mset_prod_list)
end
context ufd begin
interpretation comm_monoid_cancel: comm_monoid_cancel "mk_monoid::'a monoid"
apply (unfold_locales)
apply simp_all
using mult_left_cancel
apply (auto simp: ac_simps)
done
lemma factors_exist:
assumes "a ≠ 0"
and "¬ a dvd 1"
shows "∃fs. set fs ⊆ UNIV - {0} ∧ factors fs a"
proof-
from mset_factors_exist[OF assms]
obtain F where "mset_factors F a" by auto
also from ex_mset obtain fs where "F = mset fs" by metis
finally have fs: "mset_factors (mset fs) a".
then have "factors fs a" using assms by (subst factors_as_mset_factors, auto)
moreover have "set fs ⊆ UNIV - {0}" using fs by (auto elim!: mset_factorsE)
ultimately show ?thesis by auto
qed
lemma factors_unique:
assumes fs: "factors fs a"
and gs: "factors gs a"
and a0: "a ≠ 0"
and a1: "¬ a dvd 1"
shows "rel_mset (ddvd) (mset fs) (mset gs)"
proof-
from a1 have "a ≠ 1" by auto
with a0 fs gs have "mset_factors (mset fs) a" "mset_factors (mset gs) a" by (unfold factors_as_mset_factors)
from mset_factors_unique[OF this] show ?thesis.
qed
lemma factorial_monoid: "factorial_monoid (mk_monoid :: 'a monoid)"
by (unfold_locales; auto simp add: factors_exist factors_unique)
end
lemma (in idom) factorial_monoid_imp_ufd:
assumes "factorial_monoid (mk_monoid :: 'a monoid)"
shows "class.ufd ((*) :: 'a ⇒ _) 1 (+) 0 (-) uminus"
proof (unfold_locales)
interpret factorial_monoid "mk_monoid :: 'a monoid" by (fact assms)
{
fix x assume x: "x ≠ 0" "¬ x dvd 1"
note * = factors_exist[simplified, OF this]
with x show "∃F. mset_factors F x" by (subst(asm) factors_as_mset_factors, auto)
}
fix x F G assume FG: "mset_factors F x" "mset_factors G x"
with mset_factors_imp_not_is_unit have x1: "¬ x dvd 1" by auto
from FG(1) have x0: "x ≠ 0" by (rule mset_factors_imp_nonzero)
obtain fs gs where fsgs: "F = mset fs" "G = mset gs" using ex_mset by metis
note FG = FG[unfolded this]
then have 0: "0 ∉ set fs" "0 ∉ set gs" by (auto elim!: mset_factorsE)
from x1 have "x ≠ 1" by auto
note FG[folded factors_as_mset_factors[OF x0 this]]
from factors_unique[OF this, simplified, OF x0 x1, folded fsgs] 0
show "rel_mset (ddvd) F G" by auto
qed
subsection ‹Preservation of Irreducibility›
locale comm_semiring_1_hom = comm_monoid_mult_hom hom + zero_hom hom
for hom :: "'a :: comm_semiring_1 ⇒ 'b :: comm_semiring_1"
locale irreducibility_hom = comm_semiring_1_hom +
assumes irreducible_imp_irreducible_hom: "irreducible a ⟹ irreducible (hom a)"
begin
lemma hom_mset_factors:
assumes F: "mset_factors F p"
shows "mset_factors (image_mset hom F) (hom p)"
proof (unfold mset_factors_def, intro conjI allI impI)
from F show "hom p = prod_mset (image_mset hom F)" "image_mset hom F ≠ {#}" by (auto simp: hom_distribs)
fix f' assume "f' ∈# image_mset hom F"
then obtain f where f: "f ∈# F" and f'f: "f' = hom f" by auto
with F irreducible_imp_irreducible_hom show "irreducible f'" unfolding f'f by auto
qed
end
locale unit_preserving_hom = comm_semiring_1_hom +
assumes is_unit_hom_if: "⋀x. hom x dvd 1 ⟹ x dvd 1"
begin
lemma is_unit_hom_iff[simp]: "hom x dvd 1 ⟷ x dvd 1" using is_unit_hom_if hom_dvd by force
lemma irreducible_hom_imp_irreducible:
assumes irr: "irreducible (hom a)" shows "irreducible a"
proof (intro irreducibleI)
from irr show "a ≠ 0" by auto
from irr show "¬ a dvd 1" by (auto dest: irreducible_not_unit)
fix b c assume "a = b * c"
then have "hom a = hom b * hom c" by (simp add: hom_distribs)
with irr have "hom b dvd 1 ∨ hom c dvd 1" by (auto dest: irreducibleD)
then show "b dvd 1 ∨ c dvd 1" by simp
qed
end
locale factor_preserving_hom = unit_preserving_hom + irreducibility_hom
begin
lemma irreducible_hom[simp]: "irreducible (hom a) ⟷ irreducible a"
using irreducible_hom_imp_irreducible irreducible_imp_irreducible_hom by metis
end
lemma factor_preserving_hom_comp:
assumes f: "factor_preserving_hom f" and g: "factor_preserving_hom g"
shows "factor_preserving_hom (f o g)"
proof-
interpret f: factor_preserving_hom f by (rule f)
interpret g: factor_preserving_hom g by (rule g)
show ?thesis by (unfold_locales, auto simp: hom_distribs)
qed
context comm_semiring_isom begin
sublocale unit_preserving_hom by (unfold_locales, auto)
sublocale factor_preserving_hom
proof (standard)
fix a :: 'a
assume "irreducible a"
note a = this[unfolded irreducible_def]
show "irreducible (hom a)"
proof (rule ccontr)
assume "¬ irreducible (hom a)"
from this[unfolded Factorial_Ring.irreducible_def,simplified] a
obtain hb hc where eq: "hom a = hb * hc" and nu: "¬ hb dvd 1" "¬ hc dvd 1" by auto
from bij obtain b where hb: "hb = hom b" by (elim bij_pointE)
from bij obtain c where hc: "hc = hom c" by (elim bij_pointE)
from eq[unfolded hb hc, folded hom_mult] have "a = b * c" by auto
with nu hb hc have "a = b * c" "¬ b dvd 1" "¬ c dvd 1" by auto
with a show False by auto
qed
qed
end
subsubsection‹Back to divisibility›
lemma(in comm_semiring_1) mset_factors_mult:
assumes F: "mset_factors F a"
and G: "mset_factors G b"
shows "mset_factors (F+G) (a*b)"
proof(intro mset_factorsI)
fix f assume "f ∈# F + G"
then consider "f ∈# F" | "f ∈# G" by auto
then show "irreducible f" by(cases, insert F G, auto)
qed (insert F G, auto)
lemma(in ufd) dvd_imp_subset_factors:
assumes ab: "a dvd b"
and F: "mset_factors F a"
and G: "mset_factors G b"
shows "∃G'. G' ⊆# G ∧ rel_mset (ddvd) F G'"
proof-
from F G have a0: "a ≠ 0" and b0: "b ≠ 0" by (simp_all add: mset_factors_imp_nonzero)
from ab obtain c where c: "b = a * c" by (elim dvdE, auto)
with b0 have c0: "c ≠ 0" by auto
show ?thesis
proof(cases "c dvd 1")
case True
show ?thesis
proof(cases F)
case empty with F show ?thesis by auto
next
case (add f F')
with F
have a: "f * prod_mset F' = a"
and F': "⋀f. f ∈# F' ⟹ irreducible f"
and irrf: "irreducible f" by auto
from irrf have f0: "f ≠ 0" and f1: "¬f dvd 1" by (auto dest: irreducible_not_unit)
from a c have "(f * c) * prod_mset F' = b" by (auto simp: ac_simps)
moreover {
have "irreducible (f * c)" using True irrf by (subst irreducible_mult_unit_right)
with F' irrf have "⋀f'. f' ∈# F' + {#f * c#} ⟹ irreducible f'" by auto
}
ultimately have "mset_factors (F' + {#f * c#}) b" by (intro mset_factorsI, auto)
from mset_factors_unique[OF this G]
have F'G: "rel_mset (ddvd) (F' + {#f * c#}) G".
from True add have FF': "rel_mset (ddvd) F (F' + {#f * c#})"
by (auto simp add: multiset.rel_refl intro!: rel_mset_Plus)
have "rel_mset (ddvd) F G"
apply(rule transpD[OF multiset.rel_transp[OF transpI] FF' F'G])
using ddvd_trans.
then show ?thesis by auto
qed
next
case False
from mset_factors_exist[OF c0 this] obtain H where H: "mset_factors H c" by auto
from c mset_factors_mult[OF F H] have "mset_factors (F + H) b" by auto
note mset_factors_unique[OF this G]
from rel_mset_split[OF this] obtain G1 G2
where "G = G1 + G2" "rel_mset (ddvd) F G1" "rel_mset (ddvd) H G2" by auto
then show ?thesis by (intro exI[of _ "G1"], auto)
qed
qed
lemma(in idom) irreducible_factor_singleton:
assumes a: "irreducible a"
shows "mset_factors F a ⟷ F = {#a#}"
proof(cases F)
case empty with mset_factorsD show ?thesis by auto
next
case (add f F')
show ?thesis
proof
assume F: "mset_factors F a"
from add mset_factorsD[OF F] have *: "a = f * prod_mset F'" by auto
then have fa: "f dvd a" by auto
from * a have f0: "f ≠ 0" by auto
from add have "f ∈# F" by auto
with F have f: "irreducible f" by auto
from add have "F' ⊆# F" by auto
then have unitemp: "prod_mset F' dvd 1 ⟹ F' = {#}"
proof(induct F')
case empty then show ?case by auto
next
case (add f F')
from add have "f ∈# F" by (simp add: mset_subset_eq_insertD)
with F irreducible_not_unit have "¬ f dvd 1" by auto
then have "¬ (prod_mset F' * f) dvd 1" by simp
with add show ?case by auto
qed
show "F = {#a#}"
proof(cases "a dvd f")
case True
then obtain r where "f = a * r" by (elim dvdE, auto)
with * have "f = (r * prod_mset F') * f" by (auto simp: ac_simps)
with f0 have "r * prod_mset F' = 1" by auto
then have "prod_mset F' dvd 1" by (metis dvd_triv_right)
with unitemp * add show ?thesis by auto
next
case False with fa a f show ?thesis by (auto simp: irreducible_altdef)
qed
qed (insert a, auto)
qed
lemma(in ufd) irreducible_dvd_imp_factor:
assumes ab: "a dvd b"
and a: "irreducible a"
and G: "mset_factors G b"
shows "∃g ∈# G. a ddvd g"
proof-
from a have "mset_factors {#a#} a" by auto
from dvd_imp_subset_factors[OF ab this G]
obtain G' where G'G: "G' ⊆# G" and rel: "rel_mset (ddvd) {#a#} G'" by auto
with rel_mset_size size_1_singleton_mset size_single
obtain g where gG': "G' = {#g#}" by fastforce
from rel[unfolded this rel_mset_def]
have "a ddvd g" by auto
with gG' G'G show ?thesis by auto
qed
lemma(in idom) prod_mset_remove_units:
"prod_mset F ddvd prod_mset {# f ∈# F. ¬f dvd 1 #}"
proof(induct F)
case (add f F) then show ?case by (cases "f = 0", auto)
qed auto
lemma(in comm_semiring_1) mset_factors_imp_dvd:
assumes "mset_factors F x" and "f ∈# F" shows "f dvd x"
using assms by (simp add: dvd_prod_mset mset_factors_def)
lemma(in ufd) prime_elem_iff_irreducible[iff]:
"prime_elem x ⟷ irreducible x"
proof (intro iffI, fact prime_elem_imp_irreducible, rule prime_elemI)
assume r: "irreducible x"
then show x0: "x ≠ 0" and x1: "¬ x dvd 1" by (auto dest: irreducible_not_unit)
from irreducible_factor_singleton[OF r]
have *: "mset_factors {#x#} x" by auto
fix a b
assume "x dvd a * b"
then obtain c where abxc: "a * b = x * c" by (elim dvdE, auto)
show "x dvd a ∨ x dvd b"
proof(cases "c = 0 ∨ a = 0 ∨ b = 0")
case True with abxc show ?thesis by auto
next
case False
then have a0: "a ≠ 0" and b0: "b ≠ 0" and c0: "c ≠ 0" by auto
from x0 c0 have xc0: "x * c ≠ 0" by auto
from x1 have xc1: "¬ x * c dvd 1" by auto
show ?thesis
proof (cases "a dvd 1 ∨ b dvd 1")
case False
then have a1: "¬ a dvd 1" and b1: "¬ b dvd 1" by auto
from mset_factors_exist[OF a0 a1]
obtain F where Fa: "mset_factors F a" by auto
then have F0: "F ≠ {#}" by auto
from mset_factors_exist[OF b0 b1]
obtain G where Gb: "mset_factors G b" by auto
then have G0: "G ≠ {#}" by auto
from mset_factors_mult[OF Fa Gb]
have FGxc: "mset_factors (F + G) (x * c)" by (simp add: abxc)
show ?thesis
proof (cases "c dvd 1")
case True
from r irreducible_mult_unit_right[OF this] have "irreducible (x*c)" by simp
note irreducible_factor_singleton[OF this] FGxc
with F0 G0 have False by (cases F; cases G; auto)
then show ?thesis by auto
next
case False
from mset_factors_exist[OF c0 this] obtain H where "mset_factors H c" by auto
with * have xHxc: "mset_factors (add_mset x H) (x * c)" by force
note rel = mset_factors_unique[OF this FGxc]
obtain hs where "mset hs = H" using ex_mset by auto
then have "mset (x#hs) = add_mset x H" by auto
from rel_mset_free[OF rel this]
obtain jjs where jjsGH: "mset jjs = F + G" and rel: "list_all2 (ddvd) (x # hs) jjs" by auto
then obtain j js where jjs: "jjs = j # js" by (cases jjs, auto)
with rel have xj: "x ddvd j" by auto
from jjs jjsGH have j: "j ∈ set_mset (F + G)" by (intro union_single_eq_member, auto)
from j consider "j ∈# F" | "j ∈# G" by auto
then show ?thesis
proof(cases)
case 1
with Fa have "j dvd a" by (auto intro: mset_factors_imp_dvd)
with xj dvd_trans have "x dvd a" by auto
then show ?thesis by auto
next
case 2
with Gb have "j dvd b" by (auto intro: mset_factors_imp_dvd)
with xj dvd_trans have "x dvd b" by auto
then show ?thesis by auto
qed
qed
next
case True
then consider "a dvd 1" | "b dvd 1" by auto
then show ?thesis
proof(cases)
case 1
then obtain d where ad: "a * d = 1" by (elim dvdE, auto)
from abxc have "x * (c * d) = a * b * d" by (auto simp: ac_simps)
also have "... = a * d * b" by (auto simp: ac_simps)
finally have "x dvd b" by (intro dvdI, auto simp: ad)
then show ?thesis by auto
next
case 2
then obtain d where bd: "b * d = 1" by (elim dvdE, auto)
from abxc have "x * (c * d) = a * b * d" by (auto simp: ac_simps)
also have "... = (b * d) * a" by (auto simp: ac_simps)
finally have "x dvd a" by (intro dvdI, auto simp:bd)
then show ?thesis by auto
qed
qed
qed
qed
subsection‹Results for GCDs etc.›
lemma prod_list_remove1: "(x :: 'b :: comm_monoid_mult) ∈ set xs ⟹ prod_list (remove1 x xs) * x = prod_list xs"
by (induct xs, auto simp: ac_simps)
class comm_monoid_gcd = gcd + comm_semiring_1 +
assumes gcd_dvd1[iff]: "gcd a b dvd a"
and gcd_dvd2[iff]: "gcd a b dvd b"
and gcd_greatest: "c dvd a ⟹ c dvd b ⟹ c dvd gcd a b"
begin
lemma gcd_0_0[simp]: "gcd 0 0 = 0"
using gcd_greatest[OF dvd_0_right dvd_0_right, of 0] by auto
lemma gcd_zero_iff[simp]: "gcd a b = 0 ⟷ a = 0 ∧ b = 0"
proof
assume "gcd a b = 0"
from gcd_dvd1[of a b, unfolded this] gcd_dvd2[of a b, unfolded this]
show "a = 0 ∧ b = 0" by auto
qed auto
lemma gcd_zero_iff'[simp]: "0 = gcd a b ⟷ a = 0 ∧ b = 0"
using gcd_zero_iff by metis
lemma dvd_gcd_0_iff[simp]:
shows "x dvd gcd 0 a ⟷ x dvd a" (is ?g1)
and "x dvd gcd a 0 ⟷ x dvd a" (is ?g2)
proof-
have "a dvd gcd a 0" "a dvd gcd 0 a" by (auto intro: gcd_greatest)
with dvd_refl show ?g1 ?g2 by (auto dest: dvd_trans)
qed
lemma gcd_dvd_1[simp]: "gcd a b dvd 1 ⟷ coprime a b"
using dvd_trans[OF gcd_greatest[of _ a b], of _ 1]
by (cases "a = 0 ∧ b = 0") (auto intro!: coprimeI elim: coprimeE)
lemma dvd_imp_gcd_dvd_gcd: "b dvd c ⟹ gcd a b dvd gcd a c"
by (meson gcd_dvd1 gcd_dvd2 gcd_greatest dvd_trans)
definition listgcd :: "'a list ⇒ 'a" where
"listgcd xs = foldr gcd xs 0"
lemma listgcd_simps[simp]: "listgcd [] = 0" "listgcd (x # xs) = gcd x (listgcd xs)"
by (auto simp: listgcd_def)
lemma listgcd: "x ∈ set xs ⟹ listgcd xs dvd x"
proof (induct xs)
case (Cons y ys)
show ?case
proof (cases "x = y")
case False
with Cons have dvd: "listgcd ys dvd x" by auto
thus ?thesis unfolding listgcd_simps using dvd_trans by blast
next
case True
thus ?thesis unfolding listgcd_simps using dvd_trans by blast
qed
qed simp
lemma listgcd_greatest: "(⋀ x. x ∈ set xs ⟹ y dvd x) ⟹ y dvd listgcd xs"
by (induct xs arbitrary:y, auto intro: gcd_greatest)
end
context Rings.dvd begin
definition "is_gcd x a b ≡ x dvd a ∧ x dvd b ∧ (∀y. y dvd a ⟶ y dvd b ⟶ y dvd x)"
definition "some_gcd a b ≡ SOME x. is_gcd x a b"
lemma is_gcdI[intro!]:
assumes "x dvd a" "x dvd b" "⋀y. y dvd a ⟹ y dvd b ⟹ y dvd x"
shows "is_gcd x a b" by (insert assms, auto simp: is_gcd_def)
lemma is_gcdE[elim!]:
assumes "is_gcd x a b"
and "x dvd a ⟹ x dvd b ⟹ (⋀y. y dvd a ⟹ y dvd b ⟹ y dvd x) ⟹ thesis"
shows thesis by (insert assms, auto simp: is_gcd_def)
lemma is_gcd_some_gcdI:
assumes "∃x. is_gcd x a b" shows "is_gcd (some_gcd a b) a b"
by (unfold some_gcd_def, rule someI_ex[OF assms])
end
context comm_semiring_1 begin
lemma some_gcd_0[intro!]: "is_gcd (some_gcd a 0) a 0" "is_gcd (some_gcd 0 b) 0 b"
by (auto intro!: is_gcd_some_gcdI intro: exI[of _ a] exI[of _ b])
lemma some_gcd_0_dvd[intro!]:
"some_gcd a 0 dvd a" "some_gcd 0 b dvd b" using some_gcd_0 by auto
lemma dvd_some_gcd_0[intro!]:
"a dvd some_gcd a 0" "b dvd some_gcd 0 b" using some_gcd_0[of a] some_gcd_0[of b] by auto
end
context idom begin
lemma is_gcd_connect:
assumes "a ≠ 0" "b ≠ 0" shows "isgcd mk_monoid x a b ⟷ is_gcd x a b"
using assms by (force simp: isgcd_def)
lemma some_gcd_connect:
assumes "a ≠ 0" and "b ≠ 0" shows "somegcd mk_monoid a b = some_gcd a b"
using assms by (auto intro!: arg_cong[of _ _ Eps] simp: is_gcd_connect some_gcd_def somegcd_def)
end
context comm_monoid_gcd
begin
lemma is_gcd_gcd: "is_gcd (gcd a b) a b" using gcd_greatest by auto
lemma is_gcd_some_gcd: "is_gcd (some_gcd a b) a b" by (insert is_gcd_gcd, auto intro!: is_gcd_some_gcdI)
lemma gcd_dvd_some_gcd: "gcd a b dvd some_gcd a b" using is_gcd_some_gcd by auto
lemma some_gcd_dvd_gcd: "some_gcd a b dvd gcd a b" using is_gcd_some_gcd by (auto intro: gcd_greatest)
lemma some_gcd_ddvd_gcd: "some_gcd a b ddvd gcd a b" by (auto intro: gcd_dvd_some_gcd some_gcd_dvd_gcd)
lemma some_gcd_dvd: "some_gcd a b dvd d ⟷ gcd a b dvd d" "d dvd some_gcd a b ⟷ d dvd gcd a b"
using some_gcd_ddvd_gcd[of a b] by (auto dest:dvd_trans)
end
class idom_gcd = comm_monoid_gcd + idom
begin
interpretation raw: comm_monoid_cancel "mk_monoid :: 'a monoid"
by (unfold_locales, auto intro: mult_commute mult_assoc)
interpretation raw: gcd_condition_monoid "mk_monoid :: 'a monoid"
by (unfold_locales, auto simp: is_gcd_connect intro!: exI[of _ "gcd _ _"] dest: gcd_greatest)
lemma gcd_mult_ddvd:
"d * gcd a b ddvd gcd (d * a) (d * b)"
proof (cases "d = 0")
case True then show ?thesis by auto
next
case d0: False
show ?thesis
proof (cases "a = 0 ∨ b = 0")
case False
note some_gcd_ddvd_gcd[of a b]
with d0 have "d * gcd a b ddvd d * some_gcd a b" by auto
also have "d * some_gcd a b ddvd some_gcd (d * a) (d * b)"
using False d0 raw.gcd_mult by (simp add: some_gcd_connect)
also note some_gcd_ddvd_gcd
finally show ?thesis.
next
case True
with d0 show ?thesis
apply (elim disjE)
apply (rule ddvd_trans[of _ "d * b"]; force)
apply (rule ddvd_trans[of _ "d * a"]; force)
done
qed
qed
lemma gcd_greatest_mult: assumes cad: "c dvd a * d" and cbd: "c dvd b * d"
shows "c dvd gcd a b * d"
proof-
from gcd_greatest[OF assms] have c: "c dvd gcd (d * a) (d * b)" by (auto simp: ac_simps)
note gcd_mult_ddvd[of d a b]
then have "gcd (d * a) (d * b) dvd gcd a b * d" by (auto simp: ac_simps)
from dvd_trans[OF c this] show ?thesis .
qed
lemma listgcd_greatest_mult: "(⋀ x :: 'a. x ∈ set xs ⟹ y dvd x * z) ⟹ y dvd listgcd xs * z"
proof (induct xs)
case (Cons x xs)
from Cons have "y dvd x * z" "y dvd listgcd xs * z" by auto
thus ?case unfolding listgcd_simps by (rule gcd_greatest_mult)
qed (simp)
lemma dvd_factor_mult_gcd:
assumes dvd: "k dvd p * q" "k dvd p * r"
and q0: "q ≠ 0" and r0: "r ≠ 0"
shows "k dvd p * gcd q r"
proof -
from dvd gcd_greatest[of k "p * q" "p * r"]
have "k dvd gcd (p * q) (p * r)" by simp
also from gcd_mult_ddvd[of p q r]
have "... dvd (p * gcd q r)" by auto
finally show ?thesis .
qed
lemma coprime_mult_cross_dvd:
assumes coprime: "coprime p q" and eq: "p' * p = q' * q"
shows "p dvd q'" (is ?g1) and "q dvd p'" (is ?g2)
proof (atomize(full), cases "p = 0 ∨ q = 0")
case True
then show "?g1 ∧ ?g2"
proof
assume p0: "p = 0" with coprime have "q dvd 1" by auto
with eq p0 show ?thesis by auto
next
assume q0: "q = 0" with coprime have "p dvd 1" by auto
with eq q0 show ?thesis by auto
qed
next
case False
{
fix p q r p' q' :: 'a
assume cop: "coprime p q" and eq: "p' * p = q' * q" and p: "p ≠ 0" and q: "q ≠ 0"
and r: "r dvd p" "r dvd q"
let ?gcd = "gcd q p"
from eq have "p' * p dvd q' * q" by auto
hence d1: "p dvd q' * q" by (rule dvd_mult_right)
have d2: "p dvd q' * p" by auto
from dvd_factor_mult_gcd[OF d1 d2 q p] have 1: "p dvd q' * ?gcd" .
from q p have 2: "?gcd dvd q" by auto
from q p have 3: "?gcd dvd p" by auto
from cop[unfolded coprime_def', rule_format, OF 3 2] have "?gcd dvd 1" .
from 1 dvd_mult_unit_iff[OF this] have "p dvd q'" by auto
} note main = this
from main[OF coprime eq,of 1] False coprime coprime_commute main[OF _ eq[symmetric], of 1]
show "?g1 ∧ ?g2" by auto
qed
end
subclass (in ring_gcd) idom_gcd by (unfold_locales, auto)
lemma coprime_rewrites: "comm_monoid_mult.coprime ((*)) 1 = coprime"
apply (intro ext)
apply (subst comm_monoid_mult.coprime_def')
apply (unfold_locales)
apply (unfold dvd_rewrites)
apply (fold coprime_def') ..
locale gcd_condition =
fixes ty :: "'a :: idom itself"
assumes gcd_exists: "⋀a b :: 'a. ∃x. is_gcd x a b"
begin
sublocale idom_gcd "(*)" "1 :: 'a" "(+)" 0 "(-)" uminus some_gcd
rewrites "dvd.dvd ((*)) = (dvd)"
and "comm_monoid_mult.coprime ((*) ) 1 = Unique_Factorization.coprime"
proof-
have "is_gcd (some_gcd a b) a b" for a b :: 'a by (intro is_gcd_some_gcdI gcd_exists)
from this[unfolded is_gcd_def]
show "class.idom_gcd (*) (1 :: 'a) (+) 0 (-) uminus some_gcd" by (unfold_locales, auto simp: dvd_rewrites)
qed (simp_all add: dvd_rewrites coprime_rewrites)
end
instance semiring_gcd ⊆ comm_monoid_gcd by (intro_classes, auto)
lemma listgcd_connect: "listgcd = gcd_list"
proof (intro ext)
fix xs :: "'a list"
show "listgcd xs = gcd_list xs" by(induct xs, auto)
qed
interpretation some_gcd: gcd_condition "TYPE('a::ufd)"
proof(unfold_locales, intro exI)
interpret factorial_monoid "mk_monoid :: 'a monoid" by (fact factorial_monoid)
note d = dvd.dvd_def some_gcd_def carrier_0
fix a b :: 'a
show "is_gcd (some_gcd a b) a b"
proof (cases "a = 0 ∨ b = 0")
case True
thus ?thesis using some_gcd_0 by auto
next
case False
with gcdof_exists[of a b]
show ?thesis by (auto intro!: is_gcd_some_gcdI simp add: is_gcd_connect some_gcd_connect)
qed
qed
lemma some_gcd_listgcd_dvd_listgcd: "some_gcd.listgcd xs dvd listgcd xs"
by (induct xs, auto simp:some_gcd_dvd intro:dvd_imp_gcd_dvd_gcd)
lemma listgcd_dvd_some_gcd_listgcd: "listgcd xs dvd some_gcd.listgcd xs"
by (induct xs, auto simp:some_gcd_dvd intro:dvd_imp_gcd_dvd_gcd)
context factorial_ring_gcd begin
text ‹Do not declare the following as subclass, to avoid conflict in
‹field ⊆ gcd_condition› vs. ‹factorial_ring_gcd ⊆ gcd_condition›.
›
sublocale as_ufd: ufd
proof(unfold_locales, goal_cases)
case (1 x)
from prime_factorization_exists[OF ‹x ≠ 0›]
obtain F where f: "⋀f. f ∈# F ⟹ prime_elem f"
and Fx: "normalize (prod_mset F) = normalize x" by auto
from associatedE2[OF Fx] obtain u where u: "is_unit u" "x = u * prod_mset F"
by blast
from ‹¬ is_unit x› Fx have "F ≠ {#}" by auto
then obtain g G where F: "F = add_mset g G" by (cases F, auto)
then have "g ∈# F" by auto
with f[OF this]prime_elem_iff_irreducible
irreducible_mult_unit_left[OF unit_factor_is_unit[OF ‹x ≠ 0›]]
have g: "irreducible (u * g)" using u(1)
by (subst irreducible_mult_unit_left) simp_all
show ?case
proof (intro exI conjI mset_factorsI)
show "prod_mset (add_mset (u * g) G) = x"
using ‹x ≠ 0› by (simp add: F ac_simps u)
fix f assume "f ∈# add_mset (u * g) G"
with f[unfolded F] g prime_elem_iff_irreducible
show "irreducible f" by auto
qed auto
next
case (2 x F G)
note transpD[OF multiset.rel_transp[OF ddvd_transp],trans]
obtain fs where F: "F = mset fs" by (metis ex_mset)
have "list_all2 (ddvd) fs (map normalize fs)" by (intro list_all2_all_nthI, auto)
then have FH: "rel_mset (ddvd) F (image_mset normalize F)" by (unfold rel_mset_def F, force)
also
have FG: "image_mset normalize F = image_mset normalize G"
proof (intro prime_factorization_unique'')
from 2 have xF: "x = prod_mset F" and xG: "x = prod_mset G" by auto
from xF have "normalize x = normalize (prod_mset (image_mset normalize F))"
by (simp add: normalize_prod_mset_normalize)
with xG have nFG: "… = normalize (prod_mset (image_mset normalize G))"
by (simp_all add: normalize_prod_mset_normalize)
then show "normalize (∏i∈#image_mset normalize F. i) =
normalize (∏i∈#image_mset normalize G. i)" by auto
next
from 2 prime_elem_iff_irreducible have "f ∈# F ⟹ prime_elem f" "g ∈# G ⟹ prime_elem g" for f g
by (auto intro: prime_elemI)
then show " Multiset.Ball (image_mset normalize F) prime"
"Multiset.Ball (image_mset normalize G) prime" by auto
qed
also
obtain gs where G: "G = mset gs" by (metis ex_mset)
have "list_all2 ((ddvd)¯¯) gs (map normalize gs)" by (intro list_all2_all_nthI, auto)
then have "rel_mset (ddvd) (image_mset normalize G) G"
by (subst multiset.rel_flip[symmetric], unfold rel_mset_def G, force)
finally show ?case.
qed
end
instance int :: ufd by (intro class.ufd.of_class.intro as_ufd.ufd_axioms)
instance int :: idom_gcd by (intro_classes, auto)
instance field ⊆ ufd by (intro_classes, auto simp: dvd_field_iff)
end
Theory Unique_Factorization_Poly
section ‹Unique Factorization Domain for Polynomials›
text ‹In this theory we prove that the polynomials over a unique factorization domain (UFD) form a UFD.›
theory Unique_Factorization_Poly
imports
Unique_Factorization
Polynomial_Factorization.Missing_Polynomial_Factorial
Subresultants.More_Homomorphisms
"HOL-Computational_Algebra.Field_as_Ring"
begin
hide_const (open) module.smult
hide_const (open) Divisibility.irreducible
instantiation fract :: (idom) "{normalization_euclidean_semiring, euclidean_ring}"
begin
definition [simp]: "normalize_fract ≡ (normalize_field :: 'a fract ⇒ _)"
definition [simp]: "unit_factor_fract = (unit_factor_field :: 'a fract ⇒ _)"
definition [simp]: "euclidean_size_fract = (euclidean_size_field :: 'a fract ⇒ _)"
definition [simp]: "modulo_fract = (mod_field :: 'a fract ⇒ _)"
instance by standard (simp_all add: dvd_field_iff divide_simps)
end
instantiation fract :: (idom) euclidean_ring_gcd
begin
definition gcd_fract :: "'a fract ⇒ 'a fract ⇒ 'a fract" where
"gcd_fract ≡ Euclidean_Algorithm.gcd"
definition lcm_fract :: "'a fract ⇒ 'a fract ⇒ 'a fract" where
"lcm_fract ≡ Euclidean_Algorithm.lcm"
definition Gcd_fract :: "'a fract set ⇒ 'a fract" where
"Gcd_fract ≡ Euclidean_Algorithm.Gcd"
definition Lcm_fract :: "'a fract set ⇒ 'a fract" where
"Lcm_fract ≡ Euclidean_Algorithm.Lcm"
instance
by (standard, simp_all add: gcd_fract_def lcm_fract_def Gcd_fract_def Lcm_fract_def)
end
instantiation fract :: (idom) unique_euclidean_ring
begin
definition [simp]: "division_segment_fract (x :: 'a fract) = (1 :: 'a fract)"
instance by standard (auto split: if_splits)
end
instance fract :: (idom) field_gcd by standard auto
definition divides_ff :: "'a::idom fract ⇒ 'a fract ⇒ bool"
where "divides_ff x y ≡ ∃ r. y = x * to_fract r"
lemma ff_list_pairs:
"∃ xs. X = map (λ (x,y). Fraction_Field.Fract x y) xs ∧ 0 ∉ snd ` set xs"
proof (induct X)
case (Cons a X)
from Cons(1) obtain xs where X: "X = map (λ (x,y). Fraction_Field.Fract x y) xs" and xs: "0 ∉ snd ` set xs"
by auto
obtain x y where a: "a = Fraction_Field.Fract x y" and y: "y ≠ 0" by (cases a, auto)
show ?case unfolding X a using xs y
by (intro exI[of _ "(x,y) # xs"], auto)
qed auto
lemma divides_ff_to_fract[simp]: "divides_ff (to_fract x) (to_fract y) ⟷ x dvd y"
unfolding divides_ff_def dvd_def
by (simp add: to_fract_def eq_fract(1) mult.commute)
lemma
shows divides_ff_mult_cancel_left[simp]: "divides_ff (z * x) (z * y) ⟷ z = 0 ∨ divides_ff x y"
and divides_ff_mult_cancel_right[simp]: "divides_ff (x * z) (y * z) ⟷ z = 0 ∨ divides_ff x y"
unfolding divides_ff_def by auto
definition gcd_ff_list :: "'a::ufd fract list ⇒ 'a fract ⇒ bool" where
"gcd_ff_list X g = (
(∀ x ∈ set X. divides_ff g x) ∧
(∀ d. (∀ x ∈ set X. divides_ff d x) ⟶ divides_ff d g))"
lemma gcd_ff_list_exists: "∃ g. gcd_ff_list (X :: 'a::ufd fract list) g"
proof -
interpret some_gcd: idom_gcd "(*)" "1 :: 'a" "(+)" 0 "(-)" uminus some_gcd
rewrites "dvd.dvd ((*)) = (dvd)" by (unfold_locales, auto simp: dvd_rewrites)
from ff_list_pairs[of X] obtain xs where X: "X = map (λ (x,y). Fraction_Field.Fract x y) xs"
and xs: "0 ∉ snd ` set xs" by auto
define r where "r ≡ prod_list (map snd xs)"
have r: "r ≠ 0" unfolding r_def prod_list_zero_iff using xs by auto
define ys where "ys ≡ map (λ (x,y). x * prod_list (remove1 y (map snd xs))) xs"
{
fix i
assume "i < length X"
hence i: "i < length xs" unfolding X by auto
obtain x y where xsi: "xs ! i = (x,y)" by force
with i have "(x,y) ∈ set xs" unfolding set_conv_nth by force
hence y_mem: "y ∈ set (map snd xs)" by force
with xs have y: "y ≠ 0" by force
from i have id1: "ys ! i = x * prod_list (remove1 y (map snd xs))" unfolding ys_def using xsi by auto
from i xsi have id2: "X ! i = Fraction_Field.Fract x y" unfolding X by auto
have lp: "prod_list (remove1 y (map snd xs)) * y = r" unfolding r_def
by (rule prod_list_remove1[OF y_mem])
have "ys ! i ∈ set ys" using i unfolding ys_def by auto
moreover have "to_fract (ys ! i) = to_fract r * (X ! i)"
unfolding id1 id2 to_fract_def mult_fract
by (subst eq_fract(1), force, force simp: y, simp add: lp)
ultimately have "ys ! i ∈ set ys" "to_fract (ys ! i) = to_fract r * (X ! i)" .
} note ys = this
define G where "G ≡ some_gcd.listgcd ys"
define g where "g ≡ to_fract G * Fraction_Field.Fract 1 r"
have len: "length X = length ys" unfolding X ys_def by auto
show ?thesis
proof (rule exI[of _ g], unfold gcd_ff_list_def, intro ballI conjI impI allI)
fix x
assume "x ∈ set X"
then obtain i where i: "i < length X" and x: "x = X ! i" unfolding set_conv_nth by auto
from ys[OF i] have id: "to_fract (ys ! i) = to_fract r * x"
and ysi: "ys ! i ∈ set ys" unfolding x by auto
from some_gcd.listgcd[OF ysi] have "G dvd ys ! i" unfolding G_def .
then obtain d where ysi: "ys ! i = G * d" unfolding dvd_def by auto
have "to_fract d * (to_fract G * Fraction_Field.Fract 1 r) = x * (to_fract r * Fraction_Field.Fract 1 r)"
using id[unfolded ysi]
by (simp add: ac_simps)
also have "… = x" using r unfolding to_fract_def by (simp add: eq_fract One_fract_def)
finally have "to_fract d * (to_fract G * Fraction_Field.Fract 1 r) = x" by simp
thus "divides_ff g x" unfolding divides_ff_def g_def
by (intro exI[of _ d], auto)
next
fix d
assume "∀x ∈ set X. divides_ff d x"
hence "Ball ((λ x. to_fract r * x) ` set X) ( divides_ff (to_fract r * d))" by simp
also have "(λ x. to_fract r * x) ` set X = to_fract ` set ys"
unfolding set_conv_nth using ys len by force
finally have dvd: "Ball (set ys) (λ y. divides_ff (to_fract r * d) (to_fract y))" by auto
obtain nd dd where d: "d = Fraction_Field.Fract nd dd" and dd: "dd ≠ 0" by (cases d, auto)
{
fix y
assume "y ∈ set ys"
hence "divides_ff (to_fract r * d) (to_fract y)" using dvd by auto
from this[unfolded divides_ff_def d to_fract_def mult_fract]
obtain ra where "Fraction_Field.Fract y 1 = Fraction_Field.Fract (r * nd * ra) dd" by auto
hence "y * dd = ra * (r * nd)" by (simp add: eq_fract dd)
hence "r * nd dvd y * dd" by auto
}
hence "r * nd dvd some_gcd.listgcd ys * dd" by (rule some_gcd.listgcd_greatest_mult)
hence "divides_ff (to_fract r * d) (to_fract G)" unfolding to_fract_def d mult_fract
G_def divides_ff_def by (auto simp add: eq_fract dd dvd_def)
also have "to_fract G = to_fract r * g" unfolding g_def using r
by (auto simp: to_fract_def eq_fract)
finally show "divides_ff d g" using r by simp
qed
qed
definition some_gcd_ff_list :: "'a :: ufd fract list ⇒ 'a fract" where
"some_gcd_ff_list xs = (SOME g. gcd_ff_list xs g)"
lemma some_gcd_ff_list: "gcd_ff_list xs (some_gcd_ff_list xs)"
unfolding some_gcd_ff_list_def using gcd_ff_list_exists[of xs]
by (rule someI_ex)
lemma some_gcd_ff_list_divides: "x ∈ set xs ⟹ divides_ff (some_gcd_ff_list xs) x"
using some_gcd_ff_list[of xs] unfolding gcd_ff_list_def by auto
lemma some_gcd_ff_list_greatest: "(∀x ∈ set xs. divides_ff d x) ⟹ divides_ff d (some_gcd_ff_list xs)"
using some_gcd_ff_list[of xs] unfolding gcd_ff_list_def by auto
lemma divides_ff_refl[simp]: "divides_ff x x"
unfolding divides_ff_def
by (rule exI[of _ 1], auto simp: to_fract_def One_fract_def)
lemma divides_ff_trans:
"divides_ff x y ⟹ divides_ff y z ⟹ divides_ff x z"
unfolding divides_ff_def
by (auto simp del: to_fract_hom.hom_mult simp add: to_fract_hom.hom_mult[symmetric])
lemma divides_ff_mult_right: "a ≠ 0 ⟹ divides_ff (x * inverse a) y ⟹ divides_ff x (a * y)"
unfolding divides_ff_def divide_inverse[symmetric] by auto
definition eq_dff :: "'a :: ufd fract ⇒ 'a fract ⇒ bool" (infix "=dff" 50) where
"x =dff y ⟷ divides_ff x y ∧ divides_ff y x"
lemma eq_dffI[intro]: "divides_ff x y ⟹ divides_ff y x ⟹ x =dff y"
unfolding eq_dff_def by auto
lemma eq_dff_refl[simp]: "x =dff x"
by (intro eq_dffI, auto)
lemma eq_dff_sym: "x =dff y ⟹ y =dff x" unfolding eq_dff_def by auto
lemma eq_dff_trans[trans]: "x =dff y ⟹ y =dff z ⟹ x =dff z"
unfolding eq_dff_def using divides_ff_trans by auto
lemma eq_dff_cancel_right[simp]: "x * y =dff x * z ⟷ x = 0 ∨ y =dff z"
unfolding eq_dff_def by auto
lemma eq_dff_mult_right_trans[trans]: "x =dff y * z ⟹ z =dff u ⟹ x =dff y * u"
using eq_dff_trans by force
lemma some_gcd_ff_list_smult: "a ≠ 0 ⟹ some_gcd_ff_list (map ((*) a) xs) =dff a * some_gcd_ff_list xs"
proof
let ?g = "some_gcd_ff_list (map ((*) a) xs)"
show "divides_ff (a * some_gcd_ff_list xs) ?g"
by (rule some_gcd_ff_list_greatest, insert some_gcd_ff_list_divides[of _ xs], auto simp: divides_ff_def)
assume a: "a ≠ 0"
show "divides_ff ?g (a * some_gcd_ff_list xs)"
proof (rule divides_ff_mult_right[OF a some_gcd_ff_list_greatest], intro ballI)
fix x
assume x: "x ∈ set xs"
have "divides_ff (?g * inverse a) x = divides_ff (inverse a * ?g) (inverse a * (a * x))"
using a by (simp add: field_simps)
also have "…" using a x by (auto intro: some_gcd_ff_list_divides)
finally show "divides_ff (?g * inverse a) x" .
qed
qed
definition content_ff :: "'a::ufd fract poly ⇒ 'a fract" where
"content_ff p = some_gcd_ff_list (coeffs p)"
lemma content_ff_iff: "divides_ff x (content_ff p) ⟷ (∀ c ∈ set (coeffs p). divides_ff x c)" (is "?l = ?r")
proof
assume ?l
from divides_ff_trans[OF this, unfolded content_ff_def, OF some_gcd_ff_list_divides] show ?r ..
next
assume ?r
thus ?l unfolding content_ff_def by (intro some_gcd_ff_list_greatest, auto)
qed
lemma content_ff_divides_ff: "x ∈ set (coeffs p) ⟹ divides_ff (content_ff p) x"
unfolding content_ff_def by (rule some_gcd_ff_list_divides)
lemma content_ff_0[simp]: "content_ff 0 = 0"
using content_ff_iff[of 0 0] by (auto simp: divides_ff_def)
lemma content_ff_0_iff[simp]: "(content_ff p = 0) = (p = 0)"
proof (cases "p = 0")
case False
define a where "a ≡ last (coeffs p)"
define xs where "xs ≡ coeffs p"
from False
have mem: "a ∈ set (coeffs p)" and a: "a ≠ 0"
unfolding a_def last_coeffs_eq_coeff_degree[OF False] coeffs_def by auto
from content_ff_divides_ff[OF mem] have "divides_ff (content_ff p) a" .
with a have "content_ff p ≠ 0" unfolding divides_ff_def by auto
with False show ?thesis by auto
qed auto
lemma content_ff_eq_dff_nonzero: "content_ff p =dff x ⟹ x ≠ 0 ⟹ p ≠ 0"
using divides_ff_def eq_dff_def by force
lemma content_ff_smult: "content_ff (smult (a::'a::ufd fract) p) =dff a * content_ff p"
proof (cases "a = 0")
case False note a = this
have id: "coeffs (smult a p) = map ((*) a) (coeffs p)"
unfolding coeffs_smult using a by (simp add: Polynomial.coeffs_smult)
show ?thesis unfolding content_ff_def id using some_gcd_ff_list_smult[OF a] .
qed simp
definition normalize_content_ff
where "normalize_content_ff (p::'a::ufd fract poly) ≡ smult (inverse (content_ff p)) p"
lemma smult_normalize_content_ff: "smult (content_ff p) (normalize_content_ff p) = p"
unfolding normalize_content_ff_def
by (cases "p = 0", auto)
lemma content_ff_normalize_content_ff_1: assumes p0: "p ≠ 0"
shows "content_ff (normalize_content_ff p) =dff 1"
proof -
have "content_ff p = content_ff (smult (content_ff p) (normalize_content_ff p))" unfolding smult_normalize_content_ff ..
also have "… =dff content_ff p * content_ff (normalize_content_ff p)" by (rule content_ff_smult)
finally show ?thesis unfolding eq_dff_def divides_ff_def using p0 by auto
qed
lemma content_ff_to_fract: assumes "set (coeffs p) ⊆ range to_fract"
shows "content_ff p ∈ range to_fract"
proof -
have "divides_ff 1 (content_ff p)" using assms
unfolding content_ff_iff unfolding divides_ff_def[abs_def] by auto
thus ?thesis unfolding divides_ff_def by auto
qed
lemma content_ff_map_poly_to_fract: "content_ff (map_poly to_fract (p :: 'a :: ufd poly)) ∈ range to_fract"
by (rule content_ff_to_fract, subst coeffs_map_poly, auto)
lemma range_coeffs_to_fract: assumes "set (coeffs p) ⊆ range to_fract"
shows "∃ m. coeff p i = to_fract m"
proof -
from assms(1) to_fract_0 have "coeff p i ∈ range to_fract" using range_coeff [of p]
by auto (metis contra_subsetD to_fract_hom.hom_zero insertE range_eqI)
thus ?thesis by auto
qed
lemma divides_ff_coeff: assumes "set (coeffs p) ⊆ range to_fract" and "divides_ff (to_fract n) (coeff p i)"
shows "∃ m. coeff p i = to_fract n * to_fract m"
proof -
from range_coeffs_to_fract[OF assms(1)] obtain k where pi: "coeff p i = to_fract k" by auto
from assms(2)[unfolded this] have "n dvd k" by simp
then obtain j where k: "k = n * j" unfolding Rings.dvd_def by auto
show ?thesis unfolding pi k by auto
qed
definition inv_embed :: "'a :: ufd fract ⇒ 'a" where
"inv_embed = the_inv to_fract"
lemma inv_embed[simp]: "inv_embed (to_fract x) = x"
unfolding inv_embed_def
by (rule the_inv_f_f, auto simp: inj_on_def)
lemma inv_embed_0[simp]: "inv_embed 0 = 0" unfolding to_fract_0[symmetric] inv_embed by simp
lemma range_to_fract_embed_poly: assumes "set (coeffs p) ⊆ range to_fract"
shows "p = map_poly to_fract (map_poly inv_embed p)"
proof -
have "p = map_poly (to_fract o inv_embed) p"
by (rule sym, rule map_poly_idI, insert assms, auto)
also have "… = map_poly to_fract (map_poly inv_embed p)"
by (subst map_poly_map_poly, auto)
finally show ?thesis .
qed
lemma content_ff_to_fract_coeffs_to_fract: assumes "content_ff p ∈ range to_fract"
shows "set (coeffs p) ⊆ range to_fract"
proof
fix x
assume "x ∈ set (coeffs p)"
from content_ff_divides_ff[OF this] assms[unfolded eq_dff_def] show "x ∈ range to_fract"
unfolding divides_ff_def by (auto simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
qed
lemma content_ff_1_coeffs_to_fract: assumes "content_ff p =dff 1"
shows "set (coeffs p) ⊆ range to_fract"
proof
fix x
assume "x ∈ set (coeffs p)"
from content_ff_divides_ff[OF this] assms[unfolded eq_dff_def] show "x ∈ range to_fract"
unfolding divides_ff_def by (auto simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
qed
lemma gauss_lemma:
fixes p q :: "'a :: ufd fract poly"
shows "content_ff (p * q) =dff content_ff p * content_ff q"
proof (cases "p = 0 ∨ q = 0")
case False
hence p: "p ≠ 0" and q: "q ≠ 0" by auto
let ?c = "content_ff :: 'a fract poly ⇒ 'a fract"
{
fix p q :: "'a fract poly"
assume cp1: "?c p =dff 1" and cq1: "?c q =dff 1"
define ip where "ip ≡ map_poly inv_embed p"
define iq where "iq ≡ map_poly inv_embed q"
interpret map_poly_hom: map_poly_comm_ring_hom to_fract..
from content_ff_1_coeffs_to_fract[OF cp1] have cp: "set (coeffs p) ⊆ range to_fract" .
from content_ff_1_coeffs_to_fract[OF cq1] have cq: "set (coeffs q) ⊆ range to_fract" .
have ip: "p = map_poly to_fract ip" unfolding ip_def
by (rule range_to_fract_embed_poly[OF cp])
have iq: "q = map_poly to_fract iq" unfolding iq_def
by (rule range_to_fract_embed_poly[OF cq])
have cpq0: "?c (p * q) ≠ 0"
unfolding content_ff_0_iff using cp1 cq1 content_ff_eq_dff_nonzero[of _ 1] by auto
have cpq: "set (coeffs (p * q)) ⊆ range to_fract" unfolding ip iq
unfolding map_poly_hom.hom_mult[symmetric] to_fract_hom.coeffs_map_poly_hom by auto
have ctnt: "?c (p * q) ∈ range to_fract" using content_ff_to_fract[OF cpq] .
then obtain cpq where id: "?c (p * q) = to_fract cpq" by auto
have dvd: "divides_ff 1 (?c (p * q))" using ctnt unfolding divides_ff_def by auto
from cpq0[unfolded id] have cpq0: "cpq ≠ 0" unfolding to_fract_def Zero_fract_def by auto
hence cpqM: "cpq ∈ carrier mk_monoid" by auto
have "?c (p * q) =dff 1"
proof (rule ccontr)
assume "¬ ?c (p * q) =dff 1"
with dvd have "¬ divides_ff (?c (p * q)) 1"
unfolding eq_dff_def by auto
from this[unfolded id divides_ff_def] have cpq: "⋀ r. cpq * r ≠ 1"
by (auto simp: to_fract_def One_fract_def eq_fract)
then have cpq1: "¬ cpq dvd 1" by (auto elim:dvdE simp:ac_simps)
from mset_factors_exist[OF cpq0 cpq1]
obtain F where F: "mset_factors F cpq" by auto
have "F ≠ {#}" using F by auto
then obtain f where f: "f ∈# F" by auto
with F have irrf: "irreducible f" and f0: "f ≠ 0" by (auto dest: mset_factorsD)
from irrf have pf: "prime_elem f" by simp
note * = this[unfolded prime_elem_def]
from * have no_unit: "¬ f dvd 1" by auto
from * f0 have prime: "⋀ a b. f dvd a * b ⟹ f dvd a ∨ f dvd b" unfolding dvd_def by force
let ?f = "to_fract f"
from F f
have fdvd: "f dvd cpq" by (auto intro:mset_factors_imp_dvd)
hence "divides_ff ?f (to_fract cpq)" by simp
from divides_ff_trans[OF this, folded id, OF content_ff_divides_ff]
have dvd: "⋀ z. z ∈ set (coeffs (p * q)) ⟹ divides_ff ?f z" .
{
fix p :: "'a fract poly"
assume cp: "?c p =dff 1"
let ?P = "λ i. ¬ divides_ff ?f (coeff p i)"
{
assume "∀ c ∈ set (coeffs p). divides_ff ?f c"
hence n: "divides_ff ?f (?c p)" unfolding content_ff_iff by auto
from divides_ff_trans[OF this] cp[unfolded eq_dff_def] have "divides_ff ?f 1" by auto
also have "1 = to_fract 1" by simp
finally have "f dvd 1" by (unfold divides_ff_to_fract)
hence False using no_unit unfolding dvd_def by (auto simp: ac_simps)
}
then obtain cp where cp: "cp ∈ set (coeffs p)" and ncp: "¬ divides_ff ?f cp" by auto
hence "cp ∈ range (coeff p)" unfolding range_coeff by auto
with ncp have "∃ i. ?P i" by auto
from LeastI_ex[OF this] not_less_Least[of _ ?P]
have "∃ i. ?P i ∧ (∀ j. j < i ⟶ divides_ff ?f (coeff p j))" by blast
} note cont = this
from cont[OF cp1] obtain r where
r: "¬ divides_ff ?f (coeff p r)" and r': "⋀ i. i < r ⟹ divides_ff ?f (coeff p i)" by auto
have "∀ i. ∃ k. i < r ⟶ coeff p i = ?f * to_fract k" using divides_ff_coeff[OF cp r'] by blast
from choice[OF this] obtain rr where r': "⋀ i. i < r ⟹ coeff p i = ?f * to_fract (rr i)" by blast
let ?r = "coeff p r"
from cont[OF cq1] obtain s where
s: "¬ divides_ff ?f (coeff q s)" and s': "⋀ i. i < s ⟹ divides_ff ?f (coeff q i)" by auto
have "∀ i. ∃ k. i < s ⟶ coeff q i = ?f * to_fract k" using divides_ff_coeff[OF cq s'] by blast
from choice[OF this] obtain ss where s': "⋀ i. i < s ⟹ coeff q i = ?f * to_fract (ss i)" by blast
from range_coeffs_to_fract[OF cp] have "∀ i. ∃ m. coeff p i = to_fract m" ..
from choice[OF this] obtain pi where pi: "⋀ i. coeff p i = to_fract (pi i)" by blast
from range_coeffs_to_fract[OF cq] have "∀ i. ∃ m. coeff q i = to_fract m" ..
from choice[OF this] obtain qi where qi: "⋀ i. coeff q i = to_fract (qi i)" by blast
let ?s = "coeff q s"
let ?g = "λ i. coeff p i * coeff q (r + s - i)"
define a where "a = (∑i∈{..<r}. (rr i * qi (r + s - i)))"
define b where "b = (∑ i ∈ {Suc r..r + s}. pi i * (ss (r + s - i)))"
have "coeff (p * q) (r + s) = (∑i≤r + s. ?g i)" unfolding coeff_mult ..
also have "{..r+s} = {..< r} ∪ {r .. r+s}" by auto
also have "(∑i∈{..<r} ∪ {r..r + s}. ?g i)
= (∑i∈{..<r}. ?g i) + (∑ i ∈ {r..r + s}. ?g i)"
by (rule sum.union_disjoint, auto)
also have "(∑i∈{..<r}. ?g i) = (∑i∈{..<r}. ?f * (to_fract (rr i) * to_fract (qi (r + s - i))))"
by (rule sum.cong[OF refl], insert r' qi, auto)
also have "… = to_fract (f * a)" by (simp add: a_def sum_distrib_left)
also have "(∑ i ∈ {r..r + s}. ?g i) = ?g r + (∑ i ∈ {Suc r..r + s}. ?g i)"
by (subst sum.remove[of _ r], auto intro: sum.cong)
also have "(∑ i ∈ {Suc r..r + s}. ?g i) = (∑ i ∈ {Suc r..r + s}. ?f * (to_fract (pi i) * to_fract (ss (r + s - i))))"
by (rule sum.cong[OF refl], insert s' pi, auto)
also have "… = to_fract (f * b)" by (simp add: sum_distrib_left b_def)
finally have cpq: "coeff (p * q) (r + s) = to_fract (f * (a + b)) + ?r * ?s" by (simp add: field_simps)
{
fix i
from dvd[of "coeff (p * q) i"] have "divides_ff ?f (coeff (p * q) i)" using range_coeff[of "p * q"]
by (cases "coeff (p * q) i = 0", auto simp: divides_ff_def)
}
from this[of "r + s", unfolded cpq] have "divides_ff ?f (to_fract (f * (a + b) + pi r * qi s))"
unfolding pi qi by simp
from this[unfolded divides_ff_to_fract] have "f dvd pi r * qi s"
by (metis dvd_add_times_triv_left_iff mult.commute)
from prime[OF this] have "f dvd pi r ∨ f dvd qi s" by auto
with r s show False unfolding pi qi by auto
qed
} note main = this
define n where "n ≡ normalize_content_ff :: 'a fract poly ⇒ 'a fract poly"
let ?s = "λ p. smult (content_ff p) (n p)"
have "?c (p * q) = ?c (?s p * ?s q)" unfolding smult_normalize_content_ff n_def by simp
also have "?s p * ?s q = smult (?c p * ?c q) (n p * n q)" by (simp add: mult.commute)
also have "?c (…) =dff (?c p * ?c q) * ?c (n p * n q)" by (rule content_ff_smult)
also have "?c (n p * n q) =dff 1" unfolding n_def
by (rule main, insert p q, auto simp: content_ff_normalize_content_ff_1)
finally show ?thesis by simp
qed auto
abbreviation (input) "content_ff_ff p ≡ content_ff (map_poly to_fract p)"
lemma factorization_to_fract:
assumes q: "q ≠ 0" and factor: "map_poly to_fract (p :: 'a :: ufd poly) = q * r"
shows "∃ q' r' c. c ≠ 0 ∧ q = smult c (map_poly to_fract q') ∧
r = smult (inverse c) (map_poly to_fract r') ∧
content_ff_ff q' =dff 1 ∧ p = q' * r'"
proof -
let ?c = content_ff
let ?p = "map_poly to_fract p"
interpret map_poly_inj_comm_ring_hom "to_fract :: 'a ⇒ _"..
define cq where "cq ≡ normalize_content_ff q"
define cr where "cr ≡ smult (content_ff q) r"
define q' where "q' ≡ map_poly inv_embed cq"
define r' where "r' ≡ map_poly inv_embed cr"
from content_ff_map_poly_to_fract have cp_ff: "?c ?p ∈ range to_fract" by auto
from smult_normalize_content_ff[of q] have cqs: "q = smult (content_ff q) cq" unfolding cq_def ..
from content_ff_normalize_content_ff_1[OF q] have c_cq: "content_ff cq =dff 1" unfolding cq_def .
from content_ff_1_coeffs_to_fract[OF this] have cq_ff: "set (coeffs cq) ⊆ range to_fract" .
have factor: "?p = cq * cr" unfolding factor cr_def using cqs
by (metis mult_smult_left mult_smult_right)
from gauss_lemma[of cq cr] have cp: "?c ?p =dff ?c cq * ?c cr" unfolding factor .
with c_cq have "?c ?p =dff ?c cr"
by (metis eq_dff_mult_right_trans mult.commute mult.right_neutral)
with cp_ff have "?c cr ∈ range to_fract"
by (metis divides_ff_def to_fract_hom.hom_mult eq_dff_def image_iff range_eqI)
from content_ff_to_fract_coeffs_to_fract[OF this] have cr_ff: "set (coeffs cr) ⊆ range to_fract" by auto
have cq: "cq = map_poly to_fract q'" unfolding q'_def
by (rule range_to_fract_embed_poly[OF cq_ff])
have cr: "cr = map_poly to_fract r'" unfolding r'_def
by (rule range_to_fract_embed_poly[OF cr_ff])
from factor[unfolded cq cr]
have p: "p = q' * r'" by (simp add: injectivity)
from c_cq have ctnt: "content_ff_ff q' =dff 1" using cq q'_def by force
from cqs have idq: "q = smult (?c q) (map_poly to_fract q')" unfolding cq .
with q have cq: "?c q ≠ 0" by auto
have "r = smult (inverse (?c q)) cr" unfolding cr_def using cq by auto
also have "cr = map_poly to_fract r'" by (rule cr)
finally have idr: "r = smult (inverse (?c q)) (map_poly to_fract r')" by auto
from cq p ctnt idq idr show ?thesis by blast
qed
lemma irreducible_PM_M_PFM:
assumes irr: "irreducible p"
shows "degree p = 0 ∧ irreducible (coeff p 0) ∨
degree p ≠ 0 ∧ irreducible (map_poly to_fract p) ∧ content_ff_ff p =dff 1"
proof-
interpret map_poly_inj_idom_hom to_fract..
from irr[unfolded irreducible_altdef]
have p0: "p ≠ 0" and irr: "¬ p dvd 1" "⋀ b. b dvd p ⟹ ¬ p dvd b ⟹ b dvd 1" by auto
show ?thesis
proof (cases "degree p = 0")
case True
from degree0_coeffs[OF True] obtain a where p: "p = [:a:]" by auto
note irr = irr[unfolded p]
from p p0 have a0: "a ≠ 0" by auto
moreover have "¬ a dvd 1" using irr(1) by simp
moreover {
fix b
assume "b dvd a" "¬ a dvd b"
hence "[:b:] dvd [:a:]" "¬ [:a:] dvd [:b:]" unfolding const_poly_dvd .
from irr(2)[OF this] have "b dvd 1" unfolding const_poly_dvd_1 .
}
ultimately have "irreducible a" unfolding irreducible_altdef by auto
with True show ?thesis unfolding p by auto
next
case False
let ?E = "map_poly to_fract"
let ?p = "?E p"
have dp: "degree ?p ≠ 0" using False by simp
from p0 have p': "?p ≠ 0" by simp
moreover have "¬ ?p dvd 1"
proof
assume "?p dvd 1" then obtain q where id: "?p * q = 1" unfolding dvd_def by auto
have deg: "degree (?p * q) = degree ?p + degree q"
by (rule degree_mult_eq, insert id, auto)
from arg_cong[OF id, of degree, unfolded deg] dp show False by auto
qed
moreover {
fix q
assume "q dvd ?p" and ndvd: "¬ ?p dvd q"
then obtain r where fact: "?p = q * r" unfolding dvd_def by auto
with p' have q0: "q ≠ 0" by auto
from factorization_to_fract[OF this fact] obtain q' r' c where *: "c ≠ 0" "q = smult c (?E q')"
"r = smult (inverse c) (?E r')" "content_ff_ff q' =dff 1"
"p = q' * r'" by auto
hence "q' dvd p" unfolding dvd_def by auto
note irr = irr(2)[OF this]
have "¬ p dvd q'"
proof
assume "p dvd q'"
then obtain u where q': "q' = p * u" unfolding dvd_def by auto
from arg_cong[OF this, of "λ x. smult c (?E x)", unfolded *(2)[symmetric]]
have "q = ?p * smult c (?E u)" by simp
hence "?p dvd q" unfolding dvd_def by blast
with ndvd show False ..
qed
from irr[OF this] have "q' dvd 1" .
from divides_degree[OF this] have "degree q' = 0" by auto
from degree0_coeffs[OF this] obtain a' where "q' = [:a':]" by auto
from *(2)[unfolded this] obtain a where q: "q = [:a:]"
by (simp add: to_fract_hom.map_poly_pCons_hom)
with q0 have a: "a ≠ 0" by auto
have "q dvd 1" unfolding q const_poly_dvd_1 using a unfolding dvd_def
by (intro exI[of _ "inverse a"], auto)
}
ultimately have irr_p': "irreducible ?p" unfolding irreducible_altdef by auto
let ?c = "content_ff"
have "?c ?p ∈ range to_fract"
by (rule content_ff_to_fract, unfold to_fract_hom.coeffs_map_poly_hom, auto)
then obtain c where cp: "?c ?p = to_fract c" by auto
from p' cp have c: "c ≠ 0" by auto
have "?c ?p =dff 1" unfolding cp
proof (rule ccontr)
define cp where "cp = normalize_content_ff ?p"
from smult_normalize_content_ff[of ?p] have cps: "?p = smult (to_fract c) cp" unfolding cp_def cp ..
from content_ff_normalize_content_ff_1[OF p'] have c_cp: "content_ff cp =dff 1" unfolding cp_def .
from range_to_fract_embed_poly[OF content_ff_1_coeffs_to_fract[OF c_cp]] obtain cp' where "cp = ?E cp'" by auto
from cps[unfolded this] have "p = smult c cp'" by (simp add: injectivity)
hence dvd: "[: c :] dvd p" unfolding dvd_def by auto
have "¬ p dvd [: c :]" using divides_degree[of p "[: c :]"] c False by auto
from irr(2)[OF dvd this] have "c dvd 1" by simp
assume "¬ to_fract c =dff 1"
from this[unfolded eq_dff_def One_fract_def to_fract_def[symmetric] divides_ff_def to_fract_mult]
have c1: "⋀ r. 1 ≠ c * r" by (auto simp: ac_simps simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
with ‹c dvd 1› show False unfolding dvd_def by blast
qed
with False irr_p' show ?thesis by auto
qed
qed
lemma irreducible_M_PM:
fixes p :: "'a :: ufd poly" assumes 0: "degree p = 0" and irr: "irreducible (coeff p 0)"
shows "irreducible p"
proof (cases "p = 0")
case True
thus ?thesis using assms by auto
next
case False
from degree0_coeffs[OF 0] obtain a where p: "p = [:a:]" by auto
with False have a0: "a ≠ 0" by auto
from p irr have "irreducible a" by auto
from this[unfolded irreducible_altdef]
have a1: "¬ a dvd 1" and irr: "⋀ b. b dvd a ⟹ ¬ a dvd b ⟹ b dvd 1" by auto
{
fix b
assume *: "b dvd [:a:]" "¬ [:a:] dvd b"
from divides_degree[OF this(1)] a0 have "degree b = 0" by auto
from degree0_coeffs[OF this] obtain bb where b: "b = [: bb :]" by auto
from * irr[of bb] have "b dvd 1" unfolding b const_poly_dvd by auto
}
with a0 a1 show ?thesis by (auto simp: irreducible_altdef p)
qed
lemma primitive_irreducible_imp_degree:
"primitive (p::'a::{semiring_gcd,idom} poly) ⟹ irreducible p ⟹ degree p > 0"
by (unfold irreducible_primitive_connect[symmetric], auto)
lemma irreducible_degree_field:
fixes p :: "'a :: field poly" assumes "irreducible p"
shows "degree p > 0"
proof-
{
assume "degree p = 0"
from degree0_coeffs[OF this] assms obtain a where p: "p = [:a:]" and a: "a ≠ 0" by auto
hence "1 = p * [:inverse a:]" by auto
hence "p dvd 1" ..
hence "p ∈ Units mk_monoid" by simp
with assms have False unfolding irreducible_def by auto
} then show ?thesis by auto
qed
lemma irreducible_PFM_PM: assumes
irr: "irreducible (map_poly to_fract p)" and ct: "content_ff_ff p =dff 1"
shows "irreducible p"
proof -
let ?E = "map_poly to_fract"
let ?p = "?E p"
from ct have p0: "p ≠ 0" by (auto simp: eq_dff_def divides_ff_def)
moreover
from irreducible_degree_field[OF irr] have deg: "degree p ≠ 0" by simp
from irr[unfolded irreducible_altdef]
have irr: "⋀ b. b dvd ?p ⟹ ¬ ?p dvd b ⟹ b dvd 1" by auto
have "¬ p dvd 1" using deg divides_degree[of p 1] by auto
moreover {
fix q :: "'a poly"
assume dvd: "q dvd p" and ndvd: "¬ p dvd q"
from dvd obtain r where pqr: "p = q * r" ..
from arg_cong[OF this, of ?E] have pqr': "?p = ?E q * ?E r" by simp
from p0 pqr have q: "q ≠ 0" and r: "r ≠ 0" by auto
have dp: "degree p = degree q + degree r" unfolding pqr
by (subst degree_mult_eq, insert q r, auto)
from eq_dff_trans[OF eq_dff_sym[OF gauss_lemma[of "?E q" "?E r", folded pqr']] ct]
have ct: "content_ff (?E q) * content_ff (?E r) =dff 1" .
from content_ff_map_poly_to_fract obtain cq where cq: "content_ff (?E q) = to_fract cq" by auto
from content_ff_map_poly_to_fract obtain cr where cr: "content_ff (?E r) = to_fract cr" by auto
note ct[unfolded cq cr to_fract_mult eq_dff_def divides_ff_def]
from this[folded hom_distribs]
obtain c where c: "cq * cr * c = 1" by (auto simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
hence one: "1 = cq * (c * cr)" "1 = cr * (c * cq)" by (auto simp: ac_simps)
{
assume *: "degree q ≠ 0 ∧ degree r ≠ 0"
with dp have "degree q < degree p" by auto
hence "degree (?E q) < degree (?E p)" by simp
hence ndvd: "¬ ?p dvd ?E q" using divides_degree[of ?p "?E q"] q by auto
have "?E q dvd ?p" unfolding pqr' by auto
from irr[OF this ndvd] have "?E q dvd 1" .
from divides_degree[OF this] * have False by auto
}
hence "degree q = 0 ∨ degree r = 0" by blast
then have "q dvd 1"
proof
assume "degree q = 0"
from degree0_coeffs[OF this] q obtain a where q: "q = [:a:]" and a: "a ≠ 0" by auto
hence id: "set (coeffs (?E q)) = {to_fract a}" by auto
have "divides_ff (to_fract a) (content_ff (?E q))" unfolding content_ff_iff id by auto
from this[unfolded cq divides_ff_def, folded hom_distribs]
obtain rr where cq: "cq = a * rr" by (auto simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
with one(1) have "1 = a * (rr * c * cr)" by (auto simp: ac_simps)
hence "a dvd 1" ..
thus ?thesis by (simp add: q)
next
assume "degree r = 0"
from degree0_coeffs[OF this] r obtain a where r: "r = [:a:]" and a: "a ≠ 0" by auto
hence id: "set (coeffs (?E r)) = {to_fract a}" by auto
have "divides_ff (to_fract a) (content_ff (?E r))" unfolding content_ff_iff id by auto
note this[unfolded cr divides_ff_def to_fract_mult]
note this[folded hom_distribs]
then obtain rr where cr: "cr = a * rr" by (auto simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
with one(2) have one: "1 = a * (rr * c * cq)" by (auto simp: ac_simps)
from arg_cong[OF pqr[unfolded r], of "λ p. p * [:rr * c * cq:]"]
have "p * [:rr * c * cq:] = q * [:a * (rr * c * cq):]" by (simp add: ac_simps)
also have "… = q" unfolding one[symmetric] by auto
finally obtain r where "q = p * r" by blast
hence "p dvd q" ..
with ndvd show ?thesis by auto
qed
}
ultimately show ?thesis by (auto simp:irreducible_altdef)
qed
lemma irreducible_cases: "irreducible p ⟷
degree p = 0 ∧ irreducible (coeff p 0) ∨
degree p ≠ 0 ∧ irreducible (map_poly to_fract p) ∧ content_ff_ff p =dff 1"
using irreducible_PM_M_PFM irreducible_M_PM irreducible_PFM_PM
by blast
lemma dvd_PM_iff: "p dvd q ⟷ divides_ff (content_ff_ff p) (content_ff_ff q) ∧
map_poly to_fract p dvd map_poly to_fract q"
proof -
interpret map_poly_inj_idom_hom to_fract..
let ?E = "map_poly to_fract"
show ?thesis (is "?l = ?r")
proof
assume "p dvd q"
then obtain r where qpr: "q = p * r" ..
from arg_cong[OF this, of ?E]
have dvd: "?E p dvd ?E q" by auto
from content_ff_map_poly_to_fract obtain cq where cq: "content_ff_ff q = to_fract cq" by auto
from content_ff_map_poly_to_fract obtain cp where cp: "content_ff_ff p = to_fract cp" by auto
from content_ff_map_poly_to_fract obtain cr where cr: "content_ff_ff r = to_fract cr" by auto
from gauss_lemma[of "?E p" "?E r", folded hom_distribs qpr, unfolded cq cp cr]
have "divides_ff (content_ff_ff p) (content_ff_ff q)" unfolding cq cp eq_dff_def
by (metis divides_ff_def divides_ff_trans)
with dvd show ?r by blast
next
assume ?r
show ?l
proof (cases "q = 0")
case True
with ‹?r› show ?l by auto
next
case False note q = this
hence q': "?E q ≠ 0" by auto
from ‹?r› obtain rr where qpr: "?E q = ?E p * rr" unfolding dvd_def by auto
with q have p: "p ≠ 0" and Ep: "?E p ≠ 0" and rr: "rr ≠ 0" by auto
from gauss_lemma[of "?E p" rr, folded qpr]
have ct: "content_ff_ff q =dff content_ff_ff p * content_ff rr"
by auto
from content_ff_map_poly_to_fract[of p] obtain cp where cp: "content_ff_ff p = to_fract cp" by auto
from content_ff_map_poly_to_fract[of q] obtain cq where cq: "content_ff_ff q = to_fract cq" by auto
from ‹?r›[unfolded cp cq] have "divides_ff (to_fract cp) (to_fract cq)" ..
with ct[unfolded cp cq eq_dff_def] have "content_ff rr ∈ range to_fract"
by (metis (no_types, lifting) Ep content_ff_0_iff cp divides_ff_def
divides_ff_trans mult.commute mult_right_cancel range_eqI)
from range_to_fract_embed_poly[OF content_ff_to_fract_coeffs_to_fract[OF this]] obtain r
where rr: "rr = ?E r" by auto
from qpr[unfolded rr, folded hom_distribs]
have "q = p * r" by (rule injectivity)
thus "p dvd q" ..
qed
qed
qed
lemma factorial_monoid_poly: "factorial_monoid (mk_monoid :: 'a :: ufd poly monoid)"
proof (fold factorial_condition_one, intro conjI)
interpret M: factorial_monoid "mk_monoid :: 'a monoid" by (fact factorial_monoid)
interpret PFM: factorial_monoid "mk_monoid :: 'a fract poly monoid"
by (rule as_ufd.factorial_monoid)
interpret PM: comm_monoid_cancel "mk_monoid :: 'a poly monoid" by (unfold_locales, auto)
let ?E = "map_poly to_fract"
show "divisor_chain_condition_monoid (mk_monoid::'a poly monoid)"
proof (unfold_locales, unfold mk_monoid_simps)
let ?rel' = "{(x::'a poly, y). x ≠ 0 ∧ y ≠ 0 ∧ properfactor x y}"
let ?rel'' = "{(x::'a, y). x ≠ 0 ∧ y ≠ 0 ∧ properfactor x y}"
let ?relPM = "{(x, y). x ≠ 0 ∧ y ≠ 0 ∧ x dvd y ∧ ¬ y dvd (x :: 'a poly)}"
let ?relM = "{(x, y). x ≠ 0 ∧ y ≠ 0 ∧ x dvd y ∧ ¬ y dvd (x :: 'a)}"
have id: "?rel' = ?relPM" using properfactor_nz by auto
have id': "?rel'' = ?relM" using properfactor_nz by auto
have "wf ?rel''" using M.division_wellfounded by auto
hence wfM: "wf ?relM" using id' by auto
let ?c = "λ p. inv_embed (content_ff_ff p)"
let ?f = "λ p. (degree p, ?c p)"
note wf = wf_inv_image[OF wf_lex_prod[OF wf_less wfM], of ?f]
show "wf ?rel'" unfolding id
proof (rule wf_subset[OF wf], clarify)
fix p q :: "'a poly"
assume p: "p ≠ 0" and q: "q ≠ 0" and dvd: "p dvd q" and ndvd: "¬ q dvd p"
from dvd obtain r where qpr: "q = p * r" ..
from degree_mult_eq[of p r, folded qpr] q qpr have r: "r ≠ 0"
and deg: "degree q = degree p + degree r" by auto
show "(p,q) ∈ inv_image ({(x, y). x < y} <*lex*> ?relM) ?f"
proof (cases "degree p = degree q")
case False
with deg have "degree p < degree q" by auto
thus ?thesis by auto
next
case True
with deg have "degree r = 0" by simp
from degree0_coeffs[OF this] r obtain a where ra: "r = [:a:]" and a: "a ≠ 0" by auto
from arg_cong[OF qpr, of "λ p. ?E p * [:inverse (to_fract a):]"] a
have "?E p = ?E q * [:inverse (to_fract a):]"
by (auto simp: ac_simps ra)
hence "?E q dvd ?E p" ..
with ndvd dvd_PM_iff have ndvd: "¬ divides_ff (content_ff_ff q) (content_ff_ff p)" by auto
from content_ff_map_poly_to_fract obtain cq where cq: "content_ff_ff q = to_fract cq" by auto
from content_ff_map_poly_to_fract obtain cp where cp: "content_ff_ff p = to_fract cp" by auto
from ndvd[unfolded cp cq] have ndvd: "¬ cq dvd cp" by simp
from iffD1[OF dvd_PM_iff,OF dvd,unfolded cq cp]
have dvd: "cp dvd cq" by simp
have c_p: "?c p = cp" unfolding cp by simp
have c_q: "?c q = cq" unfolding cq by simp
from q cq have cq0: "cq ≠ 0" by auto
from p cp have cp0: "cp ≠ 0" by auto
from ndvd cq0 cp0 dvd have "(?c p, ?c q) ∈ ?relM" unfolding c_p c_q by auto
with True show ?thesis by auto
qed
qed
qed
show "primeness_condition_monoid (mk_monoid::'a poly monoid)"
proof (unfold_locales, unfold mk_monoid_simps)
fix p :: "'a poly"
assume p: "p ≠ 0" and "irred p"
then have irr: "irreducible p" by auto
from p have p': "?E p ≠ 0" by auto
from irreducible_PM_M_PFM[OF irr] have choice: "degree p = 0 ∧ irred (coeff p 0)
∨ degree p ≠ 0 ∧ irred (?E p) ∧ content_ff_ff p =dff 1" by auto
show "Divisibility.prime mk_monoid p"
proof (rule Divisibility.primeI, unfold mk_monoid_simps mem_Units)
show "¬ p dvd 1"
proof
assume "p dvd 1"
from divides_degree[OF this] have dp: "degree p = 0" by auto
from degree0_coeffs[OF this] p obtain a where p: "p = [:a:]" and a: "a ≠ 0" by auto
with choice have irr: "irreducible a" by auto
from ‹p dvd 1›[unfolded p] have "a dvd 1" by auto
with irr show False unfolding irreducible_def by auto
qed
fix q r :: "'a poly"
assume q: "q ≠ 0" and r: "r ≠ 0" and "factor p (q * r)"
from this[unfolded factor_idom] have "p dvd q * r" by auto
from iffD1[OF dvd_PM_iff this] have dvd_ct: "divides_ff (content_ff_ff p) (content_ff (?E (q * r)))"
and dvd_E: "?E p dvd ?E q * ?E r" by auto
from gauss_lemma[of "?E q" "?E r"] divides_ff_trans[OF dvd_ct, of "content_ff_ff q * content_ff_ff r"]
have dvd_ct: "divides_ff (content_ff_ff p) (content_ff_ff q * content_ff_ff r)"
unfolding eq_dff_def by auto
from choice
have "p dvd q ∨ p dvd r"
proof
assume "degree p ≠ 0 ∧ irred (?E p) ∧ content_ff_ff p =dff 1"
hence deg: "degree p ≠ 0" and irr: "irred (?E p)" and ct: "content_ff_ff p =dff 1" by auto
from PFM.irreducible_prime[OF irr] p have prime: "Divisibility.prime mk_monoid (?E p)" by auto
from q r have Eq: "?E q ∈ carrier mk_monoid" and Er: "?E r ∈ carrier mk_monoid"
and q': "?E q ≠ 0" and r': "?E r ≠ 0" and qr': "?E q * ?E r ≠ 0" by auto
from PFM.prime_divides[OF Eq Er prime] q' r' qr' dvd_E
have dvd_E: "?E p dvd ?E q ∨ ?E p dvd ?E r" by simp
from ct have ct: "divides_ff (content_ff_ff p) 1" unfolding eq_dff_def by auto
moreover have "⋀ q. divides_ff 1 (content_ff_ff q)" using content_ff_map_poly_to_fract
unfolding divides_ff_def by auto
from divides_ff_trans[OF ct this] have ct: "⋀ q. divides_ff (content_ff_ff p) (content_ff_ff q)" .
with dvd_E show ?thesis using dvd_PM_iff by blast
next
assume "degree p = 0 ∧ irred (coeff p 0)"
hence deg: "degree p = 0" and irr: "irred (coeff p 0)" by auto
from degree0_coeffs[OF deg] p obtain a where p: "p = [:a:]" and a: "a ≠ 0" by auto
with irr have irr: "irred a" and aM: "a ∈ carrier mk_monoid" by auto
from M.irreducible_prime[OF irr aM] have prime: "Divisibility.prime mk_monoid a" .
from content_ff_map_poly_to_fract obtain cq where cq: "content_ff_ff q = to_fract cq" by auto
from content_ff_map_poly_to_fract obtain cp where cp: "content_ff_ff p = to_fract cp" by auto
from content_ff_map_poly_to_fract obtain cr where cr: "content_ff_ff r = to_fract cr" by auto
have "divides_ff (to_fract a) (content_ff_ff p)" unfolding p content_ff_iff using a by auto
from divides_ff_trans[OF this[unfolded cp] dvd_ct[unfolded cp cq cr]]
have "divides_ff (to_fract a) (to_fract (cq * cr))" by simp
hence dvd: "a dvd cq * cr" by (auto simp add: divides_ff_def simp del: to_fract_hom.hom_mult simp: to_fract_hom.hom_mult[symmetric])
from content_ff_divides_ff[of "to_fract a" "?E p"] have "divides_ff (to_fract cp) (to_fract a)"
using cp a p by auto
hence cpa: "cp dvd a" by simp
from a q r cq cr have aM: "a ∈ carrier mk_monoid" and qM: "cq ∈ carrier mk_monoid" and rM: "cr ∈ carrier mk_monoid"
and q': "cq ≠ 0" and r': "cr ≠ 0" and qr': "cq * cr ≠ 0"
by auto
from M.prime_divides[OF qM rM prime] q' r' qr' dvd
have "a dvd cq ∨ a dvd cr" by simp
with dvd_trans[OF cpa] have dvd: "cp dvd cq ∨ cp dvd cr" by auto
have "⋀ q. ?E p * (smult (inverse (to_fract a)) q) = q" unfolding p using a by (auto simp: one_poly_def)
hence Edvd: "⋀ q. ?E p dvd q" unfolding dvd_def by metis
from dvd Edvd show ?thesis apply (subst(1 2) dvd_PM_iff) unfolding cp cq cr by auto
qed
thus "factor p q ∨ factor p r" unfolding factor_idom using p q r by auto
qed
qed
qed
instance poly :: (ufd) ufd
by (intro class.ufd.of_class.intro factorial_monoid_imp_ufd factorial_monoid_poly)
lemma primitive_iff_some_content_dvd_1:
fixes f :: "'a :: ufd poly"
shows "primitive f ⟷ some_gcd.listgcd (coeffs f) dvd 1" (is "_ ⟷ ?c dvd 1")
proof(intro iffI primitiveI)
fix x
assume "(⋀y. y ∈ set (coeffs f) ⟹ x dvd y)"
from some_gcd.listgcd_greatest[of "coeffs f", OF this]
have "x dvd ?c" by simp
also assume "?c dvd 1"
finally show "x dvd 1".
next
assume "primitive f"
from primitiveD[OF this some_gcd.listgcd[of _ "coeffs f"]]
show "?c dvd 1" by auto
qed
end
Theory Poly_Mod
section ‹Polynomials in Rings and Fields›
subsection ‹Polynomials in Rings›
text ‹We use a locale to work with polynomials in some integer-modulo ring.›
theory Poly_Mod
imports
"HOL-Computational_Algebra.Primes"
Polynomial_Factorization.Square_Free_Factorization
Unique_Factorization_Poly
begin
locale poly_mod = fixes m :: "int"
begin
definition M :: "int ⇒ int" where "M x = x mod m"
lemma M_0[simp]: "M 0 = 0"
by (auto simp add: M_def)
lemma M_M[simp]: "M (M x) = M x"
by (auto simp add: M_def)
lemma M_plus[simp]: "M (M x + y) = M (x + y)" "M (x + M y) = M (x + y)"
by (auto simp add: M_def mod_simps)
lemma M_minus[simp]: "M (M x - y) = M (x - y)" "M (x - M y) = M (x - y)"
by (auto simp add: M_def mod_simps)
lemma M_times[simp]: "M (M x * y) = M (x * y)" "M (x * M y) = M (x * y)"
by (auto simp add: M_def mod_simps)
lemma M_sum: "M (sum (λ x. M (f x)) A) = M (sum f A)"
proof (induct A rule: infinite_finite_induct)
case (insert x A)
from insert(1-2) have "M (∑x∈insert x A. M (f x)) = M (f x + M ((∑x∈A. M (f x))))" by simp
also have "M ((∑x∈A. M (f x))) = M ((∑x∈A. f x))" using insert by simp
finally show ?case using insert by simp
qed auto
definition inv_M :: "int ⇒ int" where
"inv_M = (λ x. if x + x ≤ m then x else x - m)"
lemma M_inv_M_id[simp]: "M (inv_M x) = M x"
unfolding inv_M_def M_def by simp
definition Mp :: "int poly ⇒ int poly" where "Mp = map_poly M"
lemma Mp_0[simp]: "Mp 0 = 0" unfolding Mp_def by auto
lemma Mp_coeff: "coeff (Mp f) i = M (coeff f i)" unfolding Mp_def
by (simp add: M_def coeff_map_poly)
abbreviation eq_m :: "int poly ⇒ int poly ⇒ bool" (infixl "=m" 50) where
"f =m g ≡ (Mp f = Mp g)"
notation eq_m (infixl "=m" 50)
abbreviation degree_m :: "int poly ⇒ nat" where
"degree_m f ≡ degree (Mp f)"
lemma mult_Mp[simp]: "Mp (Mp f * g) = Mp (f * g)" "Mp (f * Mp g) = Mp (f * g)"
proof -
{
fix f g
have "Mp (Mp f * g) = Mp (f * g)"
unfolding poly_eq_iff Mp_coeff unfolding coeff_mult Mp_coeff
proof
fix n
show "M (∑i≤n. M (coeff f i) * coeff g (n - i)) = M (∑i≤n. coeff f i * coeff g (n - i))"
by (subst M_sum[symmetric], rule sym, subst M_sum[symmetric], unfold M_times, simp)
qed
}
from this[of f g] this[of g f] show "Mp (Mp f * g) = Mp (f * g)" "Mp (f * Mp g) = Mp (f * g)"
by (auto simp: ac_simps)
qed
lemma plus_Mp[simp]: "Mp (Mp f + g) = Mp (f + g)" "Mp (f + Mp g) = Mp (f + g)"
unfolding poly_eq_iff Mp_coeff unfolding coeff_mult Mp_coeff by (auto simp add: Mp_coeff)
lemma minus_Mp[simp]: "Mp (Mp f - g) = Mp (f - g)" "Mp (f - Mp g) = Mp (f - g)"
unfolding poly_eq_iff Mp_coeff unfolding coeff_mult Mp_coeff by (auto simp add: Mp_coeff)
lemma Mp_smult[simp]: "Mp (smult (M a) f) = Mp (smult a f)" "Mp (smult a (Mp f)) = Mp (smult a f)"
unfolding Mp_def smult_as_map_poly
by (rule poly_eqI, auto simp: coeff_map_poly)+
lemma Mp_Mp[simp]: "Mp (Mp f) = Mp f" unfolding Mp_def
by (intro poly_eqI, auto simp: coeff_map_poly)
lemma Mp_smult_m_0[simp]: "Mp (smult m f) = 0"
by (intro poly_eqI, auto simp: Mp_coeff, auto simp: M_def)
definition dvdm :: "int poly ⇒ int poly ⇒ bool" (infix "dvdm" 50) where
"f dvdm g = (∃ h. g =m f * h)"
notation dvdm (infix "dvdm" 50)
lemma dvdmE:
assumes fg: "f dvdm g"
and main: "⋀h. g =m f * h ⟹ Mp h = h ⟹ thesis"
shows "thesis"
proof-
from fg obtain h where "g =m f * h" by (auto simp: dvdm_def)
then have "g =m f * Mp h" by auto
from main[OF this] show thesis by auto
qed
lemma Mp_dvdm[simp]: "Mp f dvdm g ⟷ f dvdm g"
and dvdm_Mp[simp]: "f dvdm Mp g ⟷ f dvdm g" by (auto simp: dvdm_def)
definition irreducible_m
where "irreducible_m f = (¬f =m 0 ∧ ¬ f dvdm 1 ∧ (∀a b. f =m a * b ⟶ a dvdm 1 ∨ b dvdm 1))"
definition irreducible⇩d_m :: "int poly ⇒ bool" where "irreducible⇩d_m f ≡
degree_m f > 0 ∧
(∀ g h. degree_m g < degree_m f ⟶ degree_m h < degree_m f ⟶ ¬ f =m g * h)"
definition prime_elem_m
where "prime_elem_m f ≡ ¬ f =m 0 ∧ ¬ f dvdm 1 ∧ (∀g h. f dvdm g * h ⟶ f dvdm g ∨ f dvdm h)"
lemma degree_m_le_degree [intro!]: "degree_m f ≤ degree f"
by (simp add: Mp_def degree_map_poly_le)
lemma irreducible⇩d_mI:
assumes f0: "degree_m f > 0"
and main: "⋀g h. Mp g = g ⟹ Mp h = h ⟹ degree g > 0 ⟹ degree g < degree_m f ⟹ degree h > 0 ⟹ degree h < degree_m f ⟹ f =m g * h ⟹ False"
shows "irreducible⇩d_m f"
proof (unfold irreducible⇩d_m_def, intro conjI allI impI f0 notI)
fix g h
assume deg: "degree_m g < degree_m f" "degree_m h < degree_m f" and "f =m g * h"
then have f: "f =m Mp g * Mp h" by simp
have "degree_m f ≤ degree_m g + degree_m h"
unfolding f using degree_mult_le order.trans by blast
with main[of "Mp g" "Mp h"] deg f show False by auto
qed
lemma irreducible⇩d_mE:
assumes "irreducible⇩d_m f"
and "degree_m f > 0 ⟹ (⋀g h. degree_m g < degree_m f ⟹ degree_m h < degree_m f ⟹ ¬ f =m g * h) ⟹ thesis"
shows thesis
using assms by (unfold irreducible⇩d_m_def, auto)
lemma irreducible⇩d_mD:
assumes "irreducible⇩d_m f"
shows "degree_m f > 0" and "⋀g h. degree_m g < degree_m f ⟹ degree_m h < degree_m f ⟹ ¬ f =m g * h"
using assms by (auto elim: irreducible⇩d_mE)
definition square_free_m :: "int poly ⇒ bool" where
"square_free_m f = (¬ f =m 0 ∧ (∀ g. degree_m g ≠ 0 ⟶ ¬ (g * g dvdm f)))"
definition coprime_m :: "int poly ⇒ int poly ⇒ bool" where
"coprime_m f g = (∀ h. h dvdm f ⟶ h dvdm g ⟶ h dvdm 1)"
lemma Mp_square_free_m[simp]: "square_free_m (Mp f) = square_free_m f"
unfolding square_free_m_def dvdm_def by simp
lemma square_free_m_cong: "square_free_m f ⟹ Mp f = Mp g ⟹ square_free_m g"
unfolding square_free_m_def dvdm_def by simp
lemma Mp_prod_mset[simp]: "Mp (prod_mset (image_mset Mp b)) = Mp (prod_mset b)"
proof (induct b)
case (add x b)
have "Mp (prod_mset (image_mset Mp ({#x#}+b))) = Mp (Mp x * prod_mset (image_mset Mp b))" by simp
also have "… = Mp (Mp x * Mp (prod_mset (image_mset Mp b)))" by simp
also have "… = Mp ( Mp x * Mp (prod_mset b))" unfolding add by simp
finally show ?case by simp
qed simp
lemma Mp_prod_list: "Mp (prod_list (map Mp b)) = Mp (prod_list b)"
proof (induct b)
case (Cons b xs)
have "Mp (prod_list (map Mp (b # xs))) = Mp (Mp b * prod_list (map Mp xs))" by simp
also have "… = Mp (Mp b * Mp (prod_list (map Mp xs)))" by simp
also have "… = Mp (Mp b * Mp (prod_list xs))" unfolding Cons by simp
finally show ?case by simp
qed simp
text ‹Polynomial evaluation modulo›
definition "M_poly p x ≡ M (poly p x)"
lemma M_poly_Mp[simp]: "M_poly (Mp p) = M_poly p"
proof(intro ext, induct p)
case 0 show ?case by auto
next
case IH: (pCons a p)
from IH(1) have "M_poly (Mp (pCons a p)) x = M (a + M(x * M_poly (Mp p) x))"
by (simp add: M_poly_def Mp_def)
also note IH(2)[of x]
finally show ?case by (simp add: M_poly_def)
qed
lemma Mp_lift_modulus: assumes "f =m g"
shows "poly_mod.eq_m (m * k) (smult k f) (smult k g)"
using assms unfolding poly_eq_iff poly_mod.Mp_coeff coeff_smult
unfolding poly_mod.M_def by simp
lemma Mp_ident_product: "n > 0 ⟹ Mp f = f ⟹ poly_mod.Mp (m * n) f = f"
unfolding poly_eq_iff poly_mod.Mp_coeff poly_mod.M_def
by (auto simp add: zmod_zmult2_eq) (metis mod_div_trivial mod_0)
lemma Mp_shrink_modulus: assumes "poly_mod.eq_m (m * k) f g" "k ≠ 0"
shows "f =m g"
proof -
from assms have a: "⋀ n. coeff f n mod (m * k) = coeff g n mod (m * k)"
unfolding poly_eq_iff poly_mod.Mp_coeff unfolding poly_mod.M_def by auto
show ?thesis unfolding poly_eq_iff poly_mod.Mp_coeff unfolding poly_mod.M_def
proof
fix n
show "coeff f n mod m = coeff g n mod m" using a[of n] ‹k ≠ 0›
by (metis mod_mult_right_eq mult.commute mult_cancel_left mult_mod_right)
qed
qed
lemma degree_m_le: "degree_m f ≤ degree f" unfolding Mp_def by (rule degree_map_poly_le)
lemma degree_m_eq: "coeff f (degree f) mod m ≠ 0 ⟹ m > 1 ⟹ degree_m f = degree f"
using degree_m_le[of f] unfolding Mp_def
by (auto intro: degree_map_poly simp: Mp_def poly_mod.M_def)
lemma degree_m_mult_le:
assumes eq: "f =m g * h"
shows "degree_m f ≤ degree_m g + degree_m h"
proof -
have "degree_m f = degree_m (Mp g * Mp h)" using eq by simp
also have "… ≤ degree (Mp g * Mp h)" by (rule degree_m_le)
also have "… ≤ degree_m g + degree_m h" by (rule degree_mult_le)
finally show ?thesis by auto
qed
lemma degree_m_smult_le: "degree_m (smult c f) ≤ degree_m f"
by (metis Mp_0 coeff_0 degree_le degree_m_le degree_smult_eq poly_mod.Mp_smult(2) smult_eq_0_iff)
lemma irreducible_m_Mp[simp]: "irreducible_m (Mp f) ⟷ irreducible_m f" by (simp add: irreducible_m_def)
lemma eq_m_irreducible_m: "f =m g ⟹ irreducible_m f ⟷ irreducible_m g"
using irreducible_m_Mp by metis
definition mset_factors_m where "mset_factors_m F p ≡
F ≠ {#} ∧ (∀f. f ∈# F ⟶ irreducible_m f) ∧ p =m prod_mset F"
end
declare poly_mod.M_def[code]
declare poly_mod.Mp_def[code]
declare poly_mod.inv_M_def[code]
definition Irr_Mon :: "'a :: comm_semiring_1 poly set"
where "Irr_Mon = {x. irreducible x ∧ monic x}"
definition factorization :: "'a :: comm_semiring_1 poly set ⇒ 'a poly ⇒ ('a × 'a poly multiset) ⇒ bool" where
"factorization Factors f cfs ≡ (case cfs of (c,fs) ⇒ f = (smult c (prod_mset fs)) ∧ (set_mset fs ⊆ Factors))"
definition unique_factorization :: "'a :: comm_semiring_1 poly set ⇒ 'a poly ⇒ ('a × 'a poly multiset) ⇒ bool" where
"unique_factorization Factors f cfs = (Collect (factorization Factors f) = {cfs})"
lemma irreducible_multD:
assumes l: "irreducible (a*b)"
shows "a dvd 1 ∧ irreducible b ∨ b dvd 1 ∧ irreducible a"
proof-
from l have "a dvd 1 ∨ b dvd 1" by auto
then show ?thesis
proof(elim disjE)
assume a: "a dvd 1"
with l have "irreducible b"
unfolding irreducible_def
by (meson is_unit_mult_iff mult.left_commute mult_not_zero)
with a show ?thesis by auto
next
assume a: "b dvd 1"
with l have "irreducible a"
unfolding irreducible_def
by (meson is_unit_mult_iff mult_not_zero semiring_normalization_rules(16))
with a show ?thesis by auto
qed
qed
lemma irreducible_dvd_prod_mset:
fixes p :: "'a :: field poly"
assumes irr: "irreducible p" and dvd: "p dvd prod_mset as"
shows "∃ a ∈# as. p dvd a"
proof -
from irr[unfolded irreducible_def] have deg: "degree p ≠ 0" by auto
hence p1: "¬ p dvd 1" unfolding dvd_def
by (metis degree_1 nonzero_mult_div_cancel_left div_poly_less linorder_neqE_nat mult_not_zero not_less0 zero_neq_one)
from dvd show ?thesis
proof (induct as)
case (add a as)
hence "prod_mset (add_mset a as) = a * prod_mset as" by auto
from add(2)[unfolded this] add(1) irr
show ?case by auto
qed (insert p1, auto)
qed
lemma monic_factorization_unique_mset:
fixes P::"'a::field poly multiset"
assumes eq: "prod_mset P = prod_mset Q"
and P: "set_mset P ⊆ {q. irreducible q ∧ monic q}"
and Q: "set_mset Q ⊆ {q. irreducible q ∧ monic q}"
shows "P = Q"
proof -
{
fix P Q :: "'a poly multiset"
assume id: "prod_mset P = prod_mset Q"
and P: "set_mset P ⊆ {q. irreducible q ∧ monic q}"
and Q: "set_mset Q ⊆ {q. irreducible q ∧ monic q}"
hence "P ⊆# Q"
proof (induct P arbitrary: Q)
case (add x P Q')
from add(3) have irr: "irreducible x" and mon: "monic x" by auto
have "∃ a ∈# Q'. x dvd a"
proof (rule irreducible_dvd_prod_mset[OF irr])
show "x dvd prod_mset Q'" unfolding add(2)[symmetric] by simp
qed
then obtain y Q where Q': "Q' = add_mset y Q" and xy: "x dvd y" by (meson mset_add)
from add(4) Q' have irr': "irreducible y" and mon': "monic y" by auto
have "x = y" using irr irr' xy mon mon'
by (metis irreducibleD' irreducible_not_unit poly_dvd_antisym)
hence Q': "Q' = Q + {#x#}" using Q' by auto
from mon have x0: "x ≠ 0" by auto
from arg_cong[OF add(2)[unfolded Q'], of "λ z. z div x"]
have eq: "prod_mset P = prod_mset Q" using x0 by auto
from add(3-4)[unfolded Q']
have "set_mset P ⊆ {q. irreducible q ∧ monic q}" "set_mset Q ⊆ {q. irreducible q ∧ monic q}"
by auto
from add(1)[OF eq this] show ?case unfolding Q' by auto
qed auto
}
from this[OF eq P Q] this[OF eq[symmetric] Q P]
show ?thesis by auto
qed
lemma exactly_one_monic_factorization:
assumes mon: "monic (f :: 'a :: field poly)"
shows "∃! fs. f = prod_mset fs ∧ set_mset fs ⊆ {q. irreducible q ∧ monic q}"
proof -
from monic_irreducible_factorization[OF mon]
obtain gs g where fin: "finite gs" and f: "f = (∏a∈gs. a ^ Suc (g a))"
and gs: "gs ⊆ {q. irreducible q ∧ monic q}"
by blast
from fin
have "∃ fs. set_mset fs ⊆ gs ∧ prod_mset fs = (∏a∈gs. a ^ Suc (g a))"
proof (induct gs)
case (insert a gs)
from insert(3) obtain fs where *: "set_mset fs ⊆ gs" "prod_mset fs = (∏a∈gs. a ^ Suc (g a))" by auto
let ?fs = "fs + replicate_mset (Suc (g a)) a"
show ?case
proof (rule exI[of _ "fs + replicate_mset (Suc (g a)) a"], intro conjI)
show "set_mset ?fs ⊆ insert a gs" using *(1) by auto
show "prod_mset ?fs = (∏a∈insert a gs. a ^ Suc (g a))"
by (subst prod.insert[OF insert(1-2)], auto simp: *(2))
qed
qed simp
then obtain fs where "set_mset fs ⊆ gs" "prod_mset fs = (∏a∈gs. a ^ Suc (g a))" by auto
with gs f have ex: "∃fs. f = prod_mset fs ∧ set_mset fs ⊆ {q. irreducible q ∧ monic q}"
by (intro exI[of _ fs], auto)
thus ?thesis using monic_factorization_unique_mset by blast
qed
lemma monic_prod_mset:
fixes as :: "'a :: idom poly multiset"
assumes "⋀ a. a ∈ set_mset as ⟹ monic a"
shows "monic (prod_mset as)" using assms
by (induct as, auto intro: monic_mult)
lemma exactly_one_factorization:
assumes f: "f ≠ (0 :: 'a :: field poly)"
shows "∃! cfs. factorization Irr_Mon f cfs"
proof -
let ?a = "coeff f (degree f)"
let ?b = "inverse ?a"
let ?g = "smult ?b f"
define g where "g = ?g"
from f have a: "?a ≠ 0" "?b ≠ 0" by (auto simp: field_simps)
hence "monic g" unfolding g_def by simp
note ex1 = exactly_one_monic_factorization[OF this, folded Irr_Mon_def]
then obtain fs where g: "g = prod_mset fs" "set_mset fs ⊆ Irr_Mon" by auto
let ?cfs = "(?a,fs)"
have cfs: "factorization Irr_Mon f ?cfs" unfolding factorization_def split g(1)[symmetric]
using g(2) unfolding g_def by (simp add: a field_simps)
show ?thesis
proof (rule, rule cfs)
fix dgs
assume fact: "factorization Irr_Mon f dgs"
obtain d gs where dgs: "dgs = (d,gs)" by force
from fact[unfolded factorization_def dgs split]
have fd: "f = smult d (prod_mset gs)" and gs: "set_mset gs ⊆ Irr_Mon" by auto
have "monic (prod_mset gs)" by (rule monic_prod_mset, insert gs[unfolded Irr_Mon_def], auto)
hence d: "d = ?a" unfolding fd by auto
from arg_cong[OF fd, of "λ x. smult ?b x", unfolded d g_def[symmetric]]
have "g = prod_mset gs" using a by (simp add: field_simps)
with ex1 g gs have "gs = fs" by auto
thus "dgs = ?cfs" unfolding dgs d by auto
qed
qed
lemma mod_ident_iff: "m > 0 ⟹ (x :: int) mod m = x ⟷ x ∈ {0 ..< m}"
by (metis Divides.pos_mod_bound Divides.pos_mod_sign atLeastLessThan_iff mod_pos_pos_trivial)
declare prod_mset_prod_list[simp]
lemma mult_1_is_id[simp]: "(*) (1 :: 'a :: ring_1) = id" by auto
context poly_mod
begin
lemma degree_m_eq_monic: "monic f ⟹ m > 1 ⟹ degree_m f = degree f"
by (rule degree_m_eq) auto
lemma monic_degree_m_lift: assumes "monic f" "k > 1" "m > 1"
shows "monic (poly_mod.Mp (m * k) f)"
proof -
have deg: "degree (poly_mod.Mp (m * k) f) = degree f"
by (rule poly_mod.degree_m_eq_monic[of f "m * k"], insert assms, auto simp: less_1_mult)
show ?thesis unfolding poly_mod.Mp_coeff deg assms poly_mod.M_def using assms(2-)
by (simp add: less_1_mult)
qed
end
locale poly_mod_2 = poly_mod m for m +
assumes m1: "m > 1"
begin
lemma M_1[simp]: "M 1 = 1" unfolding M_def using m1
by auto
lemma Mp_1[simp]: "Mp 1 = 1" unfolding Mp_def by simp
lemma monic_degree_m[simp]: "monic f ⟹ degree_m f = degree f"
using degree_m_eq_monic[of f] using m1 by auto
lemma monic_Mp: "monic f ⟹ monic (Mp f)"
by (auto simp: Mp_coeff)
lemma Mp_0_smult_sdiv_poly: assumes "Mp f = 0"
shows "smult m (sdiv_poly f m) = f"
proof (intro poly_eqI, unfold Mp_coeff coeff_smult sdiv_poly_def, subst coeff_map_poly, force)
fix n
from assms have "coeff (Mp f) n = 0" by simp
hence 0: "coeff f n mod m = 0" unfolding Mp_coeff M_def .
thus "m * (coeff f n div m) = coeff f n" by auto
qed
lemma Mp_product_modulus: "m' = m * k ⟹ k > 0 ⟹ Mp (poly_mod.Mp m' f) = Mp f"
by (intro poly_eqI, unfold poly_mod.Mp_coeff poly_mod.M_def, auto simp: mod_mod_cancel)
lemma inv_M_rev: assumes bnd: "2 * abs c < m"
shows "inv_M (M c) = c"
proof (cases "c ≥ 0")
case True
with bnd show ?thesis unfolding M_def inv_M_def by auto
next
case False
have 2: "⋀ v :: int. 2 * v = v + v" by auto
from False have c: "c < 0" by auto
from bnd c have "c + m > 0" "c + m < m" by auto
with c have cm: "c mod m = c + m"
by (metis le_less mod_add_self2 mod_pos_pos_trivial)
from c bnd have "2 * (c mod m) > m" unfolding cm by auto
with bnd c show ?thesis unfolding M_def inv_M_def cm by auto
qed
end
lemma (in poly_mod) degree_m_eq_prime:
assumes f0: "Mp f ≠ 0"
and deg: "degree_m f = degree f"
and eq: "f =m g * h"
and p: "prime m"
shows "degree_m f = degree_m g + degree_m h"
proof -
interpret poly_mod_2 m using prime_ge_2_int[OF p] unfolding poly_mod_2_def by simp
from f0 eq have "Mp (Mp g * Mp h) ≠ 0" by auto
hence "Mp g * Mp h ≠ 0" using Mp_0 by (cases "Mp g * Mp h", auto)
hence g0: "Mp g ≠ 0" and h0: "Mp h ≠ 0" by auto
have "degree (Mp (g * h)) = degree_m (Mp g * Mp h)" by simp
also have "… = degree (Mp g * Mp h)"
proof (rule degree_m_eq[OF _ m1], rule)
have id: "⋀ g. coeff (Mp g) (degree (Mp g)) mod m = coeff (Mp g) (degree (Mp g))"
unfolding M_def[symmetric] Mp_coeff by simp
from p have p': "prime m" unfolding prime_int_nat_transfer unfolding prime_nat_iff by auto
assume "coeff (Mp g * Mp h) (degree (Mp g * Mp h)) mod m = 0"
from this[unfolded coeff_degree_mult]
have "coeff (Mp g) (degree (Mp g)) mod m = 0 ∨ coeff (Mp h) (degree (Mp h)) mod m = 0"
unfolding dvd_eq_mod_eq_0[symmetric] using m1 prime_dvd_mult_int[OF p'] by auto
with g0 h0 show False unfolding id by auto
qed
also have "… = degree (Mp g) + degree (Mp h)"
by (rule degree_mult_eq[OF g0 h0])
finally show ?thesis using eq by simp
qed
lemma monic_smult_add_small: assumes "f = 0 ∨ degree f < degree g" and mon: "monic g"
shows "monic (g + smult q f)"
proof (cases "f = 0")
case True
thus ?thesis using mon by auto
next
case False
with assms have "degree f < degree g" by auto
hence "degree (smult q f) < degree g" by (meson degree_smult_le not_less order_trans)
thus ?thesis using mon using coeff_eq_0 degree_add_eq_left by fastforce
qed
context poly_mod
begin
definition factorization_m :: "int poly ⇒ (int × int poly multiset) ⇒ bool" where
"factorization_m f cfs ≡ (case cfs of (c,fs) ⇒ f =m (smult c (prod_mset fs)) ∧
(∀ f ∈ set_mset fs. irreducible⇩d_m f ∧ monic (Mp f)))"
definition Mf :: "int × int poly multiset ⇒ int × int poly multiset" where
"Mf cfs ≡ case cfs of (c,fs) ⇒ (M c, image_mset Mp fs)"
lemma Mf_Mf[simp]: "Mf (Mf x) = Mf x"
proof (cases x, auto simp: Mf_def, goal_cases)
case (1 c fs)
show ?case by (induct fs, auto)
qed
definition equivalent_fact_m :: "int × int poly multiset ⇒ int × int poly multiset ⇒ bool" where
"equivalent_fact_m cfs dgs = (Mf cfs = Mf dgs)"
definition unique_factorization_m :: "int poly ⇒ (int × int poly multiset) ⇒ bool" where
"unique_factorization_m f cfs = (Mf ` Collect (factorization_m f) = {Mf cfs})"
lemma Mp_irreducible⇩d_m[simp]: "irreducible⇩d_m (Mp f) = irreducible⇩d_m f"
unfolding irreducible⇩d_m_def dvdm_def by simp
lemma Mf_factorization_m[simp]: "factorization_m f (Mf cfs) = factorization_m f cfs"
unfolding factorization_m_def Mf_def
proof (cases cfs, simp, goal_cases)
case (1 c fs)
have "Mp (smult c (prod_mset fs)) = Mp (smult (M c) (Mp (prod_mset fs)))" by simp
also have "… = Mp (smult (M c) (Mp (prod_mset (image_mset Mp fs))))"
unfolding Mp_prod_mset by simp
also have "… = Mp (smult (M c) (prod_mset (image_mset Mp fs)))" unfolding Mp_smult ..
finally show ?case by auto
qed
lemma unique_factorization_m_imp_factorization: assumes "unique_factorization_m f cfs"
shows "factorization_m f cfs"
proof -
from assms[unfolded unique_factorization_m_def] obtain dfs where
fact: "factorization_m f dfs" and id: "Mf cfs = Mf dfs" by blast
from fact have "factorization_m f (Mf dfs)" by simp
from this[folded id] show ?thesis by simp
qed
lemma unique_factorization_m_alt_def: "unique_factorization_m f cfs = (factorization_m f cfs
∧ (∀ dgs. factorization_m f dgs ⟶ Mf dgs = Mf cfs))"
using unique_factorization_m_imp_factorization[of f cfs]
unfolding unique_factorization_m_def by auto
end
context poly_mod_2
begin
lemma factorization_m_lead_coeff: assumes "factorization_m f (c,fs)"
shows "lead_coeff (Mp f) = M c"
proof -
note * = assms[unfolded factorization_m_def split]
have "monic (prod_mset (image_mset Mp fs))" by (rule monic_prod_mset, insert *, auto)
hence "monic (Mp (prod_mset (image_mset Mp fs)))" by (rule monic_Mp)
from this[unfolded Mp_prod_mset] have monic: "monic (Mp (prod_mset fs))" by simp
from * have "lead_coeff (Mp f) = lead_coeff (Mp (smult c (prod_mset fs)))" by simp
also have "Mp (smult c (prod_mset fs)) = Mp (smult (M c) (Mp (prod_mset fs)))" by simp
finally show ?thesis
using monic ‹smult c (prod_mset fs) =m smult (M c) (Mp (prod_mset fs))›
by (metis M_M M_def Mp_0 Mp_coeff lead_coeff_smult m1 mult_cancel_left2 poly_mod.degree_m_eq smult_eq_0_iff)
qed
lemma factorization_m_smult: assumes "factorization_m f (c,fs)"
shows "factorization_m (smult d f) (c * d,fs)"
proof -
note * = assms[unfolded factorization_m_def split]
from * have f: "Mp f = Mp (smult c (prod_mset fs))" by simp
have "Mp (smult d f) = Mp (smult d (Mp f))" by simp
also have "… = Mp (smult (c * d) (prod_mset fs))" unfolding f by (simp add: ac_simps)
finally show ?thesis using assms
unfolding factorization_m_def split by auto
qed
lemma factorization_m_prod: assumes "factorization_m f (c,fs)" "factorization_m g (d,gs)"
shows "factorization_m (f * g) (c * d, fs + gs)"
proof -
note * = assms[unfolded factorization_m_def split]
have "Mp (f * g) = Mp (Mp f * Mp g)" by simp
also have "Mp f = Mp (smult c (prod_mset fs))" using * by simp
also have "Mp g = Mp (smult d (prod_mset gs))" using * by simp
finally have "Mp (f * g) = Mp (smult (c * d) (prod_mset (fs + gs)))" unfolding mult_Mp
by (simp add: ac_simps)
with * show ?thesis unfolding factorization_m_def split by auto
qed
lemma Mp_factorization_m[simp]: "factorization_m (Mp f) cfs = factorization_m f cfs"
unfolding factorization_m_def by simp
lemma Mp_unique_factorization_m[simp]:
"unique_factorization_m (Mp f) cfs = unique_factorization_m f cfs"
unfolding unique_factorization_m_alt_def by simp
lemma unique_factorization_m_cong: "unique_factorization_m f cfs ⟹ Mp f = Mp g
⟹ unique_factorization_m g cfs"
unfolding Mp_unique_factorization_m[of f, symmetric] by simp
lemma unique_factorization_mI: assumes "factorization_m f (c,fs)"
and "⋀ d gs. factorization_m f (d,gs) ⟹ Mf (d,gs) = Mf (c,fs)"
shows "unique_factorization_m f (c,fs)"
unfolding unique_factorization_m_alt_def
by (intro conjI[OF assms(1)] allI impI, insert assms(2), auto)
lemma unique_factorization_m_smult: assumes uf: "unique_factorization_m f (c,fs)"
and d: "M (di * d) = 1"
shows "unique_factorization_m (smult d f) (c * d,fs)"
proof (rule unique_factorization_mI[OF factorization_m_smult])
show "factorization_m f (c, fs)" using uf[unfolded unique_factorization_m_alt_def] by auto
fix e gs
assume fact: "factorization_m (smult d f) (e,gs)"
from factorization_m_smult[OF this, of di]
have "factorization_m (Mp (smult di (smult d f))) (e * di, gs)" by simp
also have "Mp (smult di (smult d f)) = Mp (smult (M (di * d)) f)" by simp
also have "… = Mp f" unfolding d by simp
finally have fact: "factorization_m f (e * di, gs)" by simp
with uf[unfolded unique_factorization_m_alt_def] have eq: "Mf (e * di, gs) = Mf (c, fs)" by blast
from eq[unfolded Mf_def] have "M (e * di) = M c" by simp
from arg_cong[OF this, of "λ x. M (x * d)"]
have "M (e * M (di * d)) = M (c * d)" by (simp add: ac_simps)
from this[unfolded d] have e: "M e = M (c * d)" by simp
with eq
show "Mf (e,gs) = Mf (c * d, fs)" unfolding Mf_def split by simp
qed
lemma unique_factorization_m_smultD: assumes uf: "unique_factorization_m (smult d f) (c,fs)"
and d: "M (di * d) = 1"
shows "unique_factorization_m f (c * di,fs)"
proof -
from d have d': "M (d * di) = 1" by (simp add: ac_simps)
show ?thesis
proof (rule unique_factorization_m_cong[OF unique_factorization_m_smult[OF uf d']],
rule poly_eqI, unfold Mp_coeff coeff_smult)
fix n
have "M (di * (d * coeff f n)) = M (M (di * d) * coeff f n)" by (auto simp: ac_simps)
from this[unfolded d] show "M (di * (d * coeff f n)) = M (coeff f n)" by simp
qed
qed
lemma degree_m_eq_lead_coeff: "degree_m f = degree f ⟹ lead_coeff (Mp f) = M (lead_coeff f)"
by (simp add: Mp_coeff)
lemma unique_factorization_m_zero: assumes "unique_factorization_m f (c,fs)"
shows "M c ≠ 0"
proof
assume c: "M c = 0"
from unique_factorization_m_imp_factorization[OF assms]
have "Mp f = Mp (smult (M c) (prod_mset fs))" unfolding factorization_m_def split
by simp
from this[unfolded c] have f: "Mp f = 0" by simp
have "factorization_m f (0,{#})"
unfolding factorization_m_def split f by auto
moreover have "Mf (0,{#}) = (0,{#})" unfolding Mf_def by auto
ultimately have fact1: "(0, {#}) ∈ Mf ` Collect (factorization_m f)" by force
define g :: "int poly" where "g = [:0,1:]"
have mpg: "Mp g = [:0,1:]" unfolding Mp_def
by (auto simp: g_def)
{
fix g h
assume *: "degree (Mp g) = 0" "degree (Mp h) = 0" "[:0, 1:] = Mp (g * h)"
from arg_cong[OF *(3), of degree] have "1 = degree_m (Mp g * Mp h)" by simp
also have "… ≤ degree (Mp g * Mp h)" by (rule degree_m_le)
also have "… ≤ degree (Mp g) + degree (Mp h)" by (rule degree_mult_le)
also have "… ≤ 0" using * by simp
finally have False by simp
} note irr = this
have "factorization_m f (0,{# g #})"
unfolding factorization_m_def split using irr
by (auto simp: irreducible⇩d_m_def f mpg)
moreover have "Mf (0,{# g #}) = (0,{# g #})" unfolding Mf_def by (auto simp: mpg, simp add: g_def)
ultimately have fact2: "(0, {#g#}) ∈ Mf ` Collect (factorization_m f)" by force
note [simp] = assms[unfolded unique_factorization_m_def]
from fact1[simplified, folded fact2[simplified]] show False by auto
qed
end
context poly_mod
begin
lemma dvdm_smult: assumes "f dvdm g"
shows "f dvdm smult c g"
proof -
from assms[unfolded dvdm_def] obtain h where g: "g =m f * h" by auto
show ?thesis unfolding dvdm_def
proof (intro exI[of _ "smult c h"])
have "Mp (smult c g) = Mp (smult c (Mp g))" by simp
also have "Mp g = Mp (f * h)" using g by simp
finally show "Mp (smult c g) = Mp (f * smult c h)" by simp
qed
qed
lemma dvdm_factor: assumes "f dvdm g"
shows "f dvdm g * h"
proof -
from assms[unfolded dvdm_def] obtain k where g: "g =m f * k" by auto
show ?thesis unfolding dvdm_def
proof (intro exI[of _ "h * k"])
have "Mp (g * h) = Mp (Mp g * h)" by simp
also have "Mp g = Mp (f * k)" using g by simp
finally show "Mp (g * h) = Mp (f * (h * k))" by (simp add: ac_simps)
qed
qed
lemma square_free_m_smultD: assumes "square_free_m (smult c f)"
shows "square_free_m f"
unfolding square_free_m_def
proof (intro conjI allI impI)
fix g
assume "degree_m g ≠ 0"
with assms[unfolded square_free_m_def] have "¬ g * g dvdm smult c f" by auto
thus "¬ g * g dvdm f" using dvdm_smult[of "g * g" f c] by blast
next
from assms[unfolded square_free_m_def] have "¬ smult c f =m 0" by simp
thus "¬ f =m 0"
by (metis Mp_smult(2) smult_0_right)
qed
lemma square_free_m_smultI: assumes sf: "square_free_m f"
and inv: "M (ci * c) = 1"
shows "square_free_m (smult c f)"
proof -
have "square_free_m (smult ci (smult c f))"
proof (rule square_free_m_cong[OF sf], rule poly_eqI, unfold Mp_coeff coeff_smult)
fix n
have "M (ci * (c * coeff f n)) = M ( M (ci * c) * coeff f n)" by (simp add: ac_simps)
from this[unfolded inv] show "M (coeff f n) = M (ci * (c * coeff f n))" by simp
qed
from square_free_m_smultD[OF this] show ?thesis .
qed
lemma square_free_m_factor: assumes "square_free_m (f * g)"
shows "square_free_m f" "square_free_m g"
proof -
{
fix f g
assume sf: "square_free_m (f * g)"
have "square_free_m f"
unfolding square_free_m_def
proof (intro conjI allI impI)
fix h
assume "degree_m h ≠ 0"
with sf[unfolded square_free_m_def] have "¬ h * h dvdm f * g" by auto
thus "¬ h * h dvdm f" using dvdm_factor[of "h * h" f g] by blast
next
from sf[unfolded square_free_m_def] have "¬ f * g =m 0" by simp
thus "¬ f =m 0"
by (metis mult.commute mult_zero_right poly_mod.mult_Mp(2))
qed
}
from this[of f g] this[of g f] assms
show "square_free_m f" "square_free_m g" by (auto simp: ac_simps)
qed
end
context poly_mod_2
begin
lemma Mp_ident_iff: "Mp f = f ⟷ (∀ n. coeff f n ∈ {0 ..< m})"
proof -
have m0: "m > 0" using m1 by simp
show ?thesis unfolding poly_eq_iff Mp_coeff M_def mod_ident_iff[OF m0] by simp
qed
lemma Mp_ident_iff': "Mp f = f ⟷ (set (coeffs f) ⊆ {0 ..< m})"
proof -
have 0: "0 ∈ {0 ..< m}" using m1 by auto
have ran: "(∀n. coeff f n ∈ {0..<m}) ⟷ range (coeff f) ⊆ {0 ..< m}" by blast
show ?thesis unfolding Mp_ident_iff ran using range_coeff[of f] 0 by auto
qed
end
lemma Mp_Mp_pow_is_Mp: "n ≠ 0 ⟹ p > 1 ⟹ poly_mod.Mp p (poly_mod.Mp (p^n) f)
= poly_mod.Mp p f"
using poly_mod_2.Mp_product_modulus poly_mod_2_def by(subst power_eq_if, auto)
lemma M_M_pow_is_M: "n ≠ 0 ⟹ p > 1 ⟹ poly_mod.M p (poly_mod.M (p^n) f)
= poly_mod.M p f" using Mp_Mp_pow_is_Mp[of n p "[:f:]"]
by (metis coeff_pCons_0 poly_mod.Mp_coeff)
definition inverse_mod :: "int ⇒ int ⇒ int" where
"inverse_mod x m = fst (bezout_coefficients x m)"
lemma inverse_mod:
"(inverse_mod x m * x) mod m = 1"
if "coprime x m" "m > 1"
proof -
from bezout_coefficients [of x m "inverse_mod x m" "snd (bezout_coefficients x m)"]
have "inverse_mod x m * x + snd (bezout_coefficients x m) * m = gcd x m"
by (simp add: inverse_mod_def)
with that have "inverse_mod x m * x + snd (bezout_coefficients x m) * m = 1"
by simp
then have "(inverse_mod x m * x + snd (bezout_coefficients x m) * m) mod m = 1 mod m"
by simp
with ‹m > 1› show ?thesis
by simp
qed
lemma inverse_mod_pow:
"(inverse_mod x (p ^ n) * x) mod (p ^ n) = 1"
if "coprime x p" "p > 1" "n ≠ 0"
using that by (auto intro: inverse_mod)
lemma (in poly_mod) inverse_mod_coprime:
assumes p: "prime m"
and cop: "coprime x m" shows "M (inverse_mod x m * x) = 1"
unfolding M_def using inverse_mod_pow[OF cop, of 1] p
by (auto simp: prime_int_iff)
lemma (in poly_mod) inverse_mod_coprime_exp:
assumes m: "m = p^n" and p: "prime p"
and n: "n ≠ 0" and cop: "coprime x p"
shows "M (inverse_mod x m * x) = 1"
unfolding M_def unfolding m using inverse_mod_pow[OF cop _ n] p
by (auto simp: prime_int_iff)
locale poly_mod_prime = poly_mod p for p :: int +
assumes prime: "prime p"
begin
sublocale poly_mod_2 p using prime unfolding poly_mod_2_def
using prime_gt_1_int by force
lemma square_free_m_prod_imp_coprime_m: assumes sf: "square_free_m (A * B)"
shows "coprime_m A B"
unfolding coprime_m_def
proof (intro allI impI)
fix h
assume dvd: "h dvdm A" "h dvdm B"
then obtain ha hb where *: "Mp A = Mp (h * ha)" "Mp B = Mp (h * hb)"
unfolding dvdm_def by auto
have AB: "Mp (A * B) = Mp (Mp A * Mp B)" by simp
from this[unfolded *, simplified]
have eq: "Mp (A * B) = Mp (h * h * (ha * hb))" by (simp add: ac_simps)
hence dvd_hh: "(h * h) dvdm (A * B)" unfolding dvdm_def by auto
{
assume "degree_m h ≠ 0"
from sf[unfolded square_free_m_def, THEN conjunct2, rule_format, OF this]
have "¬ h * h dvdm A * B" .
with dvd_hh have False by simp
}
hence "degree (Mp h) = 0" by auto
then obtain c where hc: "Mp h = [: c :]" by (rule degree_eq_zeroE)
{
assume "c = 0"
hence "Mp h = 0" unfolding hc by auto
with *(1) have "Mp A = 0"
by (metis Mp_0 mult_zero_left poly_mod.mult_Mp(1))
with sf[unfolded square_free_m_def, THEN conjunct1] have False
by (simp add: AB)
}
hence c0: "c ≠ 0" by auto
with arg_cong[OF hc[symmetric], of "λ f. coeff f 0", unfolded Mp_coeff M_def] m1
have "c ≥ 0" "c < p" by auto
with c0 have c_props:"c > 0" "c < p" by auto
with prime have "prime p" by simp
with c_props have "coprime p c"
by (auto intro: prime_imp_coprime dest: zdvd_not_zless)
then have "coprime c p"
by (simp add: ac_simps)
from inverse_mod_coprime[OF prime this]
obtain d where d: "M (c * d) = 1" by (auto simp: ac_simps)
show "h dvdm 1" unfolding dvdm_def
proof (intro exI[of _ "[:d:]"])
have "Mp (h * [: d :]) = Mp (Mp h * [: d :])" by simp
also have "… = Mp ([: c * d :])" unfolding hc by (auto simp: ac_simps)
also have "… = [: M (c * d) :]" unfolding Mp_def
by (metis (no_types) M_0 map_poly_pCons Mp_0 Mp_def d zero_neq_one)
also have "… = 1" unfolding d by simp
finally show "Mp 1 = Mp (h * [:d:])" by simp
qed
qed
lemma coprime_exp_mod: "coprime lu p ⟹ n ≠ 0 ⟹ lu mod p ^ n ≠ 0"
using prime by fastforce
end
context poly_mod
begin
definition Dp :: "int poly ⇒ int poly" where
"Dp f = map_poly (λ a. a div m) f"
lemma Dp_Mp_eq: "f = Mp f + smult m (Dp f)"
by (rule poly_eqI, auto simp: Mp_coeff M_def Dp_def coeff_map_poly)
lemma dvd_imp_dvdm:
assumes "a dvd b" shows "a dvdm b"
by (metis assms dvd_def dvdm_def)
lemma dvdm_add:
assumes a: "u dvdm a"
and b: "u dvdm b"
shows "u dvdm (a+b)"
proof -
obtain a' where a: "a =m u*a'" using a unfolding dvdm_def by auto
obtain b' where b: "b =m u*b'" using b unfolding dvdm_def by auto
have "Mp (a + b) = Mp (u*a'+u*b')" using a b
by (metis poly_mod.plus_Mp(1) poly_mod.plus_Mp(2))
also have "... = Mp (u * (a'+ b'))"
by (simp add: distrib_left)
finally show ?thesis unfolding dvdm_def by auto
qed
lemma monic_dvdm_constant:
assumes uk: "u dvdm [:k:]"
and u1: "monic u" and u2: "degree u > 0"
shows "k mod m = 0"
proof -
have d1: "degree_m [:k:] = degree [:k:]"
by (metis degree_pCons_0 le_zero_eq poly_mod.degree_m_le)
obtain h where h: "Mp [:k:] = Mp (u * h)"
using uk unfolding dvdm_def by auto
have d2: "degree_m [:k:] = degree_m (u*h)" using h by metis
have d3: "degree (map_poly M (u * map_poly M h)) = degree (u * map_poly M h)"
by (rule degree_map_poly)
(metis coeff_degree_mult leading_coeff_0_iff mult.right_neutral M_M Mp_coeff Mp_def u1)
thus ?thesis using assms d1 d2 d3
by (auto, metis M_def map_poly_pCons degree_mult_right_le h leD map_poly_0
mult_poly_0_right pCons_eq_0_iff M_0 Mp_def mult_Mp(2))
qed
lemma div_mod_imp_dvdm:
assumes "∃q r. b = q * a + Polynomial.smult m r"
shows "a dvdm b"
proof -
from assms obtain q r where b:"b = a * q + smult m r"
by (metis mult.commute)
have a: "Mp (Polynomial.smult m r) = 0" by auto
show ?thesis
proof (unfold dvdm_def, rule exI[of _ q])
have "Mp (a * q + smult m r) = Mp (a * q + Mp (smult m r))"
using plus_Mp(2)[of "a*q" "smult m r"] by auto
also have "... = Mp (a*q)" by auto
finally show "eq_m b (a * q)" using b by auto
qed
qed
lemma lead_coeff_monic_mult:
fixes p :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
assumes "monic p" shows "lead_coeff (p * q) = lead_coeff q"
using assms by (simp add: lead_coeff_mult)
lemma degree_m_mult_eq:
assumes p: "monic p" and q: "lead_coeff q mod m ≠ 0" and m1: "m > 1"
shows "degree (Mp (p * q)) = degree p + degree q"
proof-
have "lead_coeff (p * q) mod m ≠ 0"
using q p by (auto simp: lead_coeff_monic_mult)
with m1 show ?thesis
by (auto simp: degree_m_eq intro!: degree_mult_eq)
qed
lemma dvdm_imp_degree_le:
assumes pq: "p dvdm q" and p: "monic p" and q0: "Mp q ≠ 0" and m1: "m > 1"
shows "degree p ≤ degree q"
proof-
from q0
have q: "lead_coeff (Mp q) mod m ≠ 0"
by (metis Mp_Mp Mp_coeff leading_coeff_neq_0 M_def)
from pq obtain r where Mpq: "Mp q = Mp (p * Mp r)" by (auto elim: dvdmE)
with p q have "lead_coeff (Mp r) mod m ≠ 0"
by (metis Mp_Mp Mp_coeff leading_coeff_0_iff mult_poly_0_right M_def)
from degree_m_mult_eq[OF p this m1] Mpq
have "degree p ≤ degree_m q" by simp
thus ?thesis using degree_m_le le_trans by blast
qed
lemma dvdm_uminus [simp]:
"p dvdm -q ⟷ p dvdm q"
by (metis add.inverse_inverse dvdm_smult smult_1_left smult_minus_left)
lemma Mp_const_poly: "Mp [:a:] = [:a mod m:]"
by (simp add: Mp_def M_def Polynomial.map_poly_pCons)
lemma dvdm_imp_div_mod:
assumes "u dvdm g"
shows "∃q r. g = q*u + smult m r"
proof -
obtain q where q: "Mp g = Mp (u*q)"
using assms unfolding dvdm_def by fast
have "(u*q) = Mp (u*q) + smult m (Dp (u*q))"
by (simp add: poly_mod.Dp_Mp_eq[of "u*q"])
hence uq: "Mp (u*q) = (u*q) - smult m (Dp (u*q))"
by auto
have g: "g = Mp g + smult m (Dp g)"
by (simp add: poly_mod.Dp_Mp_eq[of "g"])
also have "... = poly_mod.Mp m (u*q) + smult m (Dp g)" using q by simp
also have "... = u * q - smult m (Dp (u * q)) + smult m (Dp g)"
unfolding uq by auto
also have "... = u * q + smult m (-Dp (u*q)) + smult m (Dp g)" by auto
also have "... = u * q + smult m (-Dp (u*q) + Dp g)"
unfolding smult_add_right by auto
also have "... = q * u + smult m (-Dp (u*q) + Dp g)" by auto
finally show ?thesis by auto
qed
corollary div_mod_iff_dvdm:
shows "a dvdm b = (∃q r. b = q * a + Polynomial.smult m r)"
using div_mod_imp_dvdm dvdm_imp_div_mod by blast
lemma dvdmE':
assumes "p dvdm q" and "⋀r. q =m p * Mp r ⟹ thesis"
shows thesis
using assms by (auto simp: dvdm_def)
end
context poly_mod_2
begin
lemma factorization_m_mem_dvdm: assumes fact: "factorization_m f (c,fs)"
and mem: "Mp g ∈# image_mset Mp fs"
shows "g dvdm f"
proof -
from fact have "factorization_m f (Mf (c, fs))" by auto
then obtain l where f: "factorization_m f (l, image_mset Mp fs)" by (auto simp: Mf_def)
from multi_member_split[OF mem] obtain ls where
fs: "image_mset Mp fs = {# Mp g #} + ls" by auto
from f[unfolded fs split factorization_m_def] show "g dvdm f"
unfolding dvdm_def
by (intro exI[of _ "smult l (prod_mset ls)"], auto simp del: Mp_smult
simp add: Mp_smult(2)[of _ "Mp g * prod_mset ls", symmetric], simp)
qed
lemma dvdm_degree: "monic u ⟹ u dvdm f ⟹ Mp f ≠ 0 ⟹ degree u ≤ degree f"
using dvdm_imp_degree_le m1 by blast
end
lemma (in poly_mod_prime) pl_dvdm_imp_p_dvdm:
assumes l0: "l ≠ 0"
and pl_dvdm: "poly_mod.dvdm (p^l) a b"
shows "a dvdm b"
proof -
from l0 have l_gt_0: "l > 0" by auto
with m1 interpret pl: poly_mod_2 "p^l" by (unfold_locales, auto)
from l_gt_0 have p_rw: "p * p ^ (l - 1) = p ^ l"
by (cases l) simp_all
obtain q r where b: "b = q * a + smult (p^l) r" using pl.dvdm_imp_div_mod[OF pl_dvdm] by auto
have "smult (p^l) r = smult p (smult (p ^ (l - 1)) r)" unfolding smult_smult p_rw ..
hence b2: "b = q * a + smult p (smult (p ^ (l - 1)) r)" using b by auto
show ?thesis
by (rule div_mod_imp_dvdm, rule exI[of _ q],
rule exI[of _ "(smult (p ^ (l - 1)) r)"], auto simp add: b2)
qed
endTheory Poly_Mod_Finite_Field
subsection ‹Polynomials in a Finite Field›
text ‹We connect polynomials in a prime field with integer polynomials modulo some prime.›
theory Poly_Mod_Finite_Field
imports
Finite_Field
Polynomial_Interpolation.Ring_Hom_Poly
"HOL-Types_To_Sets.Types_To_Sets"
Missing_Multiset2
Poly_Mod
begin
declare rel_mset_Zero[transfer_rule]
lemma mset_transfer[transfer_rule]: "(list_all2 rel ===> rel_mset rel) mset mset"
proof (intro rel_funI)
show "list_all2 rel xs ys ⟹ rel_mset rel (mset xs) (mset ys)" for xs ys
proof (induct xs arbitrary: ys)
case Nil
then show ?case by auto
next
case IH: (Cons x xs)
then show ?case by (auto dest!:msed_rel_invL simp: list_all2_Cons1 intro!:rel_mset_Plus)
qed
qed
abbreviation to_int_poly :: "'a :: finite mod_ring poly ⇒ int poly" where
"to_int_poly ≡ map_poly to_int_mod_ring"
interpretation to_int_poly_hom: map_poly_inj_zero_hom to_int_mod_ring ..
lemma irreducible⇩d_def_0:
fixes f :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
shows "irreducible⇩d f = (degree f ≠ 0 ∧
(∀ g h. degree g ≠ 0 ⟶ degree h ≠ 0 ⟶ f ≠ g * h))"
proof-
have "degree g ≠ 0 ⟹ g ≠ 0" for g :: "'a poly" by auto
note 1 = degree_mult_eq[OF this this, simplified]
then show ?thesis by (force elim!: irreducible⇩dE)
qed
subsection ‹Transferring to class-based mod-ring›
locale poly_mod_type = poly_mod m
for m and ty :: "'a :: nontriv itself" +
assumes m: "m = CARD('a)"
begin
lemma m1: "m > 1" using nontriv[where 'a = 'a] by (auto simp:m)
sublocale poly_mod_2 using m1 by unfold_locales
definition MP_Rel :: "int poly ⇒ 'a mod_ring poly ⇒ bool"
where "MP_Rel f f' ≡ (Mp f = to_int_poly f')"
definition M_Rel :: "int ⇒ 'a mod_ring ⇒ bool"
where "M_Rel x x' ≡ (M x = to_int_mod_ring x')"
definition "MF_Rel ≡ rel_prod M_Rel (rel_mset MP_Rel)"
lemma to_int_mod_ring_plus: "to_int_mod_ring ((x :: 'a mod_ring) + y) = M (to_int_mod_ring x + to_int_mod_ring y)"
unfolding M_def using m by (transfer, auto)
lemma to_int_mod_ring_times: "to_int_mod_ring ((x :: 'a mod_ring) * y) = M (to_int_mod_ring x * to_int_mod_ring y)"
unfolding M_def using m by (transfer, auto)
lemma degree_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) degree_m degree"
unfolding MP_Rel_def rel_fun_def
by (auto intro!: degree_map_poly)
lemma eq_M_Rel[transfer_rule]: "(M_Rel ===> M_Rel ===> (=)) (λ x y. M x = M y) (=)"
unfolding M_Rel_def rel_fun_def by auto
interpretation to_int_mod_ring_hom: map_poly_inj_zero_hom to_int_mod_ring..
lemma eq_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> (=)) (=m) (=)"
unfolding MP_Rel_def rel_fun_def by auto
lemma eq_Mf_Rel[transfer_rule]: "(MF_Rel ===> MF_Rel ===> (=)) (λ x y. Mf x = Mf y) (=)"
proof (intro rel_funI, goal_cases)
case (1 cfs Cfs dgs Dgs)
obtain c fs where cfs: "cfs = (c,fs)" by force
obtain C Fs where Cfs: "Cfs = (C,Fs)" by force
obtain d gs where dgs: "dgs = (d,gs)" by force
obtain D Gs where Dgs: "Dgs = (D,Gs)" by force
note pairs = cfs Cfs dgs Dgs
from 1[unfolded pairs MF_Rel_def rel_prod.simps]
have *[transfer_rule]: "M_Rel c C" "M_Rel d D" "rel_mset MP_Rel fs Fs" "rel_mset MP_Rel gs Gs"
by auto
have eq1: "(M c = M d) = (C = D)" by transfer_prover
from *(3)[unfolded rel_mset_def] obtain fs' Fs' where fs_eq: "mset fs' = fs" "mset Fs' = Fs"
and rel_f: "list_all2 MP_Rel fs' Fs'" by auto
from *(4)[unfolded rel_mset_def] obtain gs' Gs' where gs_eq: "mset gs' = gs" "mset Gs' = Gs"
and rel_g: "list_all2 MP_Rel gs' Gs'" by auto
have eq2: "(image_mset Mp fs = image_mset Mp gs) = (Fs = Gs)"
using *(3-4)
proof (induct fs arbitrary: Fs gs Gs)
case (empty Fs gs Gs)
from empty(1) have Fs: "Fs = {#}" unfolding rel_mset_def by auto
with empty show ?case by (cases gs; cases Gs; auto simp: rel_mset_def)
next
case (add f fs Fs' gs' Gs')
note [transfer_rule] = add(3)
from msed_rel_invL[OF add(2)]
obtain Fs F where Fs': "Fs' = Fs + {#F#}" and rel[transfer_rule]:
"MP_Rel f F" "rel_mset MP_Rel fs Fs" by auto
note IH = add(1)[OF rel(2)]
{
from add(3)[unfolded rel_mset_def] obtain gs Gs where id: "mset gs = gs'" "mset Gs = Gs'"
and rel: "list_all2 MP_Rel gs Gs" by auto
have "Mp f ∈# image_mset Mp gs' ⟷ F ∈# Gs'"
proof -
have "?thesis = ((Mp f ∈ Mp ` set gs) = (F ∈ set Gs))"
unfolding id[symmetric] by simp
also have … using rel
proof (induct gs Gs rule: list_all2_induct)
case (Cons g gs G Gs)
note [transfer_rule] = Cons(1-2)
have id: "(Mp g = Mp f) = (F = G)" by (transfer, auto)
show ?case using id Cons(3) by auto
qed auto
finally show ?thesis by simp
qed
} note id = this
show ?case
proof (cases "Mp f ∈# image_mset Mp gs'")
case False
have "Mp f ∈# image_mset Mp (fs + {#f#})" by auto
with False have F: "image_mset Mp (fs + {#f#}) ≠ image_mset Mp gs'" by metis
with False[unfolded id] show ?thesis unfolding Fs' by auto
next
case True
then obtain g where fg: "Mp f = Mp g" and g: "g ∈# gs'" by auto
from g obtain gs where gs': "gs' = add_mset g gs" by (rule mset_add)
from msed_rel_invL[OF add(3)[unfolded gs']]
obtain Gs G where Gs': "Gs' = Gs + {# G #}" and gG[transfer_rule]: "MP_Rel g G" and
gsGs: "rel_mset MP_Rel gs Gs" by auto
have FG: "F = G" by (transfer, simp add: fg)
note IH = IH[OF gsGs]
show ?thesis unfolding gs' Fs' Gs' by (simp add: fg IH FG)
qed
qed
show "(Mf cfs = Mf dgs) = (Cfs = Dgs)" unfolding pairs Mf_def split
by (simp add: eq1 eq2)
qed
lemmas coeff_map_poly_of_int = coeff_map_poly[of of_int, OF of_int_0]
lemma plus_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> MP_Rel) (+) (+)"
unfolding MP_Rel_def
proof (intro rel_funI, goal_cases)
case (1 x f y g)
have "Mp (x + y) = Mp (Mp x + Mp y)" by simp
also have "… = Mp (map_poly to_int_mod_ring f + map_poly to_int_mod_ring g)" unfolding 1 ..
also have "… = map_poly to_int_mod_ring (f + g)" unfolding poly_eq_iff Mp_coeff
by (auto simp: to_int_mod_ring_plus)
finally show ?case .
qed
lemma times_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> MP_Rel) ((*)) ((*))"
unfolding MP_Rel_def
proof (intro rel_funI, goal_cases)
case (1 x f y g)
have "Mp (x * y) = Mp (Mp x * Mp y)" by simp
also have "… = Mp (map_poly to_int_mod_ring f * map_poly to_int_mod_ring g)" unfolding 1 ..
also have "… = map_poly to_int_mod_ring (f * g)"
proof -
{ fix n :: nat
define A where "A = {.. n}"
have "finite A" unfolding A_def by auto
then have "M (∑i≤n. to_int_mod_ring (coeff f i) * to_int_mod_ring (coeff g (n - i))) =
to_int_mod_ring (∑i≤n. coeff f i * coeff g (n - i))"
unfolding A_def[symmetric]
proof (induct A)
case (insert a A)
have "?case = ?case" (is "(?l = ?r) = _") by simp
have "?r = to_int_mod_ring (coeff f a * coeff g (n - a) + (∑i∈ A. coeff f i * coeff g (n - i)))"
using insert(1-2) by auto
note r = this[unfolded to_int_mod_ring_plus to_int_mod_ring_times]
from insert(1-2) have "?l = M (to_int_mod_ring (coeff f a) * to_int_mod_ring (coeff g (n - a))
+ M (∑i∈A. to_int_mod_ring (coeff f i) * to_int_mod_ring (coeff g (n - i))))"
by simp
also have "M (∑i∈A. to_int_mod_ring (coeff f i) * to_int_mod_ring (coeff g (n - i))) = to_int_mod_ring (∑i∈A. coeff f i * coeff g (n - i))"
unfolding insert ..
finally
show ?case unfolding r by simp
qed auto
}
then show ?thesis by (auto intro!:poly_eqI simp: coeff_mult Mp_coeff)
qed
finally show ?case .
qed
lemma smult_MP_Rel[transfer_rule]: "(M_Rel ===> MP_Rel ===> MP_Rel) smult smult"
unfolding MP_Rel_def M_Rel_def
proof (intro rel_funI, goal_cases)
case (1 x x' f f')
thus ?case unfolding poly_eq_iff coeff Mp_coeff
coeff_smult M_def
proof (intro allI, goal_cases)
case (1 n)
have "x * coeff f n mod m = (x mod m) * (coeff f n mod m) mod m"
by (simp add: mod_simps)
also have "… = to_int_mod_ring x' * (to_int_mod_ring (coeff f' n)) mod m"
using 1 by auto
also have " … = to_int_mod_ring (x' * coeff f' n)"
unfolding to_int_mod_ring_times M_def by simp
finally show ?case by auto
qed
qed
lemma one_M_Rel[transfer_rule]: "M_Rel 1 1"
unfolding M_Rel_def M_def
unfolding m by auto
lemma one_MP_Rel[transfer_rule]: "MP_Rel 1 1"
unfolding MP_Rel_def poly_eq_iff Mp_coeff M_def
unfolding m by auto
lemma zero_M_Rel[transfer_rule]: "M_Rel 0 0"
unfolding M_Rel_def M_def
unfolding m by auto
lemma zero_MP_Rel[transfer_rule]: "MP_Rel 0 0"
unfolding MP_Rel_def poly_eq_iff Mp_coeff M_def
unfolding m by auto
lemma listprod_MP_Rel[transfer_rule]: "(list_all2 MP_Rel ===> MP_Rel) prod_list prod_list"
proof (intro rel_funI, goal_cases)
case (1 xs ys)
thus ?case
proof (induct xs ys rule: list_all2_induct)
case (Cons x xs y ys)
note [transfer_rule] = this
show ?case by simp transfer_prover
qed (simp add: one_MP_Rel)
qed
lemma prod_mset_MP_Rel[transfer_rule]: "(rel_mset MP_Rel ===> MP_Rel) prod_mset prod_mset"
proof (intro rel_funI, goal_cases)
case (1 xs ys)
have "(MP_Rel ===> MP_Rel ===> MP_Rel) ((*)) ((*))" "MP_Rel 1 1" by transfer_prover+
from 1 this show ?case
proof (induct xs ys rule: rel_mset_induct)
case (add R x xs y ys)
note [transfer_rule] = this
show ?case by simp transfer_prover
qed (simp add: one_MP_Rel)
qed
lemma right_unique_MP_Rel[transfer_rule]: "right_unique MP_Rel"
unfolding right_unique_def MP_Rel_def by auto
lemma M_to_int_mod_ring: "M (to_int_mod_ring (x :: 'a mod_ring)) = to_int_mod_ring x"
unfolding M_def unfolding m by (transfer, auto)
lemma Mp_to_int_poly: "Mp (to_int_poly (f :: 'a mod_ring poly)) = to_int_poly f"
by (auto simp: poly_eq_iff Mp_coeff M_to_int_mod_ring)
lemma right_total_M_Rel[transfer_rule]: "right_total M_Rel"
unfolding right_total_def M_Rel_def using M_to_int_mod_ring by blast
lemma left_total_M_Rel[transfer_rule]: "left_total M_Rel"
unfolding left_total_def M_Rel_def[abs_def]
proof
fix x
show "∃ x' :: 'a mod_ring. M x = to_int_mod_ring x'" unfolding M_def unfolding m
by (rule exI[of _ "of_int x"], transfer, simp)
qed
lemma bi_total_M_Rel[transfer_rule]: "bi_total M_Rel"
using right_total_M_Rel left_total_M_Rel by (metis bi_totalI)
lemma right_total_MP_Rel[transfer_rule]: "right_total MP_Rel"
unfolding right_total_def MP_Rel_def
proof
fix f :: "'a mod_ring poly"
show "∃x. Mp x = to_int_poly f"
by (intro exI[of _ "to_int_poly f"], simp add: Mp_to_int_poly)
qed
lemma to_int_mod_ring_of_int_M: "to_int_mod_ring (of_int x :: 'a mod_ring) = M x" unfolding M_def
unfolding m by transfer auto
lemma Mp_f_representative: "Mp f = to_int_poly (map_poly of_int f :: 'a mod_ring poly)"
unfolding Mp_def by (auto intro: poly_eqI simp: coeff_map_poly to_int_mod_ring_of_int_M)
lemma left_total_MP_Rel[transfer_rule]: "left_total MP_Rel"
unfolding left_total_def MP_Rel_def[abs_def] using Mp_f_representative by blast
lemma bi_total_MP_Rel[transfer_rule]: "bi_total MP_Rel"
using right_total_MP_Rel left_total_MP_Rel by (metis bi_totalI)
lemma bi_total_MF_Rel[transfer_rule]: "bi_total MF_Rel"
unfolding MF_Rel_def[abs_def]
by (intro prod.bi_total_rel multiset.bi_total_rel bi_total_MP_Rel bi_total_M_Rel)
lemma right_total_MF_Rel[transfer_rule]: "right_total MF_Rel"
using bi_total_MF_Rel unfolding bi_total_alt_def by auto
lemma left_total_MF_Rel[transfer_rule]: "left_total MF_Rel"
using bi_total_MF_Rel unfolding bi_total_alt_def by auto
lemma domain_RT_rel[transfer_domain_rule]: "Domainp MP_Rel = (λ f. True)"
proof
fix f :: "int poly"
show "Domainp MP_Rel f = True" unfolding MP_Rel_def[abs_def] Domainp.simps
by (auto simp: Mp_f_representative)
qed
lemma mem_MP_Rel[transfer_rule]: "(MP_Rel ===> rel_set MP_Rel ===> (=)) (λ x Y. ∃y ∈ Y. eq_m x y) (∈)"
proof (intro rel_funI iffI)
fix x y X Y assume xy: "MP_Rel x y" and XY: "rel_set MP_Rel X Y"
{ assume "∃x' ∈ X. x =m x'"
then obtain x' where x'X: "x' ∈ X" and xx': "x =m x'" by auto
with xy have x'y: "MP_Rel x' y" by (auto simp: MP_Rel_def)
from rel_setD1[OF XY x'X] obtain y' where "MP_Rel x' y'" and "y' ∈ Y" by auto
with x'y
show "y ∈ Y" by (auto simp: MP_Rel_def)
}
assume "y ∈ Y"
from rel_setD2[OF XY this] obtain x' where x'X: "x' ∈ X" and x'y: "MP_Rel x' y" by auto
from xy x'y have "x =m x'" by (auto simp: MP_Rel_def)
with x'X show "∃x' ∈ X. x =m x'" by auto
qed
lemma conversep_MP_Rel_OO_MP_Rel [simp]: "MP_Rel¯¯ OO MP_Rel = (=)"
using Mp_to_int_poly by (intro ext, auto simp: OO_def MP_Rel_def)
lemma MP_Rel_OO_conversep_MP_Rel [simp]: "MP_Rel OO MP_Rel¯¯ = eq_m"
by (intro ext, auto simp: OO_def MP_Rel_def Mp_f_representative)
lemma conversep_MP_Rel_OO_eq_m [simp]: "MP_Rel¯¯ OO eq_m = MP_Rel¯¯"
by (intro ext, auto simp: OO_def MP_Rel_def)
lemma eq_m_OO_MP_Rel [simp]: "eq_m OO MP_Rel = MP_Rel"
by (intro ext, auto simp: OO_def MP_Rel_def)
lemma eq_mset_MP_Rel [transfer_rule]: "(rel_mset MP_Rel ===> rel_mset MP_Rel ===> (=)) (rel_mset eq_m) (=)"
proof (intro rel_funI iffI)
fix A B X Y
assume AX: "rel_mset MP_Rel A X" and BY: "rel_mset MP_Rel B Y"
{
assume AB: "rel_mset eq_m A B"
from AX have "rel_mset MP_Rel¯¯ X A" by (simp add: multiset.rel_flip)
note rel_mset_OO[OF this AB]
note rel_mset_OO[OF this BY]
then show "X = Y" by (simp add: multiset.rel_eq)
}
assume "X = Y"
with BY have "rel_mset MP_Rel¯¯ X B" by (simp add: multiset.rel_flip)
from rel_mset_OO[OF AX this]
show "rel_mset eq_m A B" by simp
qed
lemma dvd_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> (=)) (dvdm) (dvd)"
unfolding dvdm_def[abs_def] dvd_def[abs_def]
by transfer_prover
lemma irreducible_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) irreducible_m irreducible"
unfolding irreducible_m_def irreducible_def
by transfer_prover
lemma irreducible⇩d_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) irreducible⇩d_m irreducible⇩d"
unfolding irreducible⇩d_m_def[abs_def] irreducible⇩d_def[abs_def]
by transfer_prover
lemma UNIV_M_Rel[transfer_rule]: "rel_set M_Rel {0..<m} UNIV"
unfolding rel_set_def M_Rel_def[abs_def] M_def
by (auto simp: M_def m, goal_cases, metis to_int_mod_ring_of_int_mod_ring, (transfer, auto)+)
lemma coeff_MP_Rel [transfer_rule]: "(MP_Rel ===> (=) ===> M_Rel) coeff coeff"
unfolding rel_fun_def M_Rel_def MP_Rel_def Mp_coeff[symmetric] by auto
lemma M_1_1: "M 1 = 1" unfolding M_def unfolding m by simp
lemma square_free_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) square_free_m square_free"
unfolding square_free_m_def[abs_def] square_free_def[abs_def]
by (transfer_prover_start, transfer_step+, auto)
lemma mset_factors_m_MP_Rel [transfer_rule]: "(rel_mset MP_Rel ===> MP_Rel ===> (=)) mset_factors_m mset_factors"
unfolding mset_factors_def mset_factors_m_def
by (transfer_prover_start, transfer_step+, auto dest:eq_m_irreducible_m)
lemma coprime_MP_Rel [transfer_rule]: "(MP_Rel ===> MP_Rel ===> (=)) coprime_m coprime"
unfolding coprime_m_def[abs_def] coprime_def' [abs_def]
by (transfer_prover_start, transfer_step+, auto)
lemma prime_elem_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) prime_elem_m prime_elem"
unfolding prime_elem_m_def prime_elem_def by transfer_prover
end
context poly_mod_2 begin
lemma non_empty: "{0..<m} ≠ {}" using m1 by auto
lemma type_to_set:
assumes type_def: "∃(Rep :: 'b ⇒ int) Abs. type_definition Rep Abs {0 ..< m :: int}"
shows "class.nontriv (TYPE('b))" (is ?a) and "m = int CARD('b)" (is ?b)
proof -
from type_def obtain rep :: "'b ⇒ int" and abs :: "int ⇒ 'b" where t: "type_definition rep abs {0 ..< m}" by auto
have "card (UNIV :: 'b set) = card {0 ..< m}" using t by (rule type_definition.card)
also have "… = m" using m1 by auto
finally show ?b ..
then show ?a unfolding class.nontriv_def using m1 by auto
qed
end
locale poly_mod_prime_type = poly_mod_type m ty for m :: int and
ty :: "'a :: prime_card itself"
begin
lemma factorization_MP_Rel [transfer_rule]:
"(MP_Rel ===> MF_Rel ===> (=)) factorization_m (factorization Irr_Mon)"
unfolding rel_fun_def
proof (intro allI impI, goal_cases)
case (1 f F cfs Cfs)
note [transfer_rule] = 1(1)
obtain c fs where cfs: "cfs = (c,fs)" by force
obtain C Fs where Cfs: "Cfs = (C,Fs)" by force
from 1(2)[unfolded rel_prod.simps cfs Cfs MF_Rel_def]
have tr[transfer_rule]: "M_Rel c C" "rel_mset MP_Rel fs Fs" by auto
have eq: "(f =m smult c (prod_mset fs) = (F = smult C (prod_mset Fs)))"
by transfer_prover
have "set_mset Fs ⊆ Irr_Mon = (∀ x ∈# Fs. irreducible⇩d x ∧ monic x)" unfolding Irr_Mon_def by auto
also have "… = (∀f∈#fs. irreducible⇩d_m f ∧ monic (Mp f))"
proof (rule sym, transfer_prover_start, transfer_step+)
{
fix f
assume "f ∈# fs"
have "monic (Mp f) ⟷ M (coeff f (degree_m f)) = M 1"
unfolding Mp_coeff[symmetric] by simp
}
thus "(∀f∈#fs. irreducible⇩d_m f ∧ monic (Mp f)) =
(∀x∈#fs. irreducible⇩d_m x ∧ M (coeff x (degree_m x)) = M 1)" by auto
qed
finally
show "factorization_m f cfs = factorization Irr_Mon F Cfs" unfolding cfs Cfs
factorization_m_def factorization_def split eq by simp
qed
lemma unique_factorization_MP_Rel [transfer_rule]: "(MP_Rel ===> MF_Rel ===> (=))
unique_factorization_m (unique_factorization Irr_Mon)"
unfolding rel_fun_def
proof (intro allI impI, goal_cases)
case (1 f F cfs Cfs)
note [transfer_rule] = 1(1,2)
let ?F = "factorization Irr_Mon F"
let ?f = "factorization_m f"
let ?R = "Collect ?F"
let ?L = "Mf ` Collect ?f"
note X_to_x = right_total_MF_Rel[unfolded right_total_def, rule_format]
{
fix X
assume "X ∈ ?R"
hence F: "?F X" by simp
from X_to_x[of X] obtain x where rel[transfer_rule]: "MF_Rel x X" by blast
from F[untransferred] have "Mf x ∈ ?L" by blast
with rel have "∃ x. Mf x ∈ ?L ∧ MF_Rel x X" by blast
} note R_to_L = this
show "unique_factorization_m f cfs = unique_factorization Irr_Mon F Cfs" unfolding
unique_factorization_m_def unique_factorization_def
proof -
have fF: "?F Cfs = ?f cfs" by transfer simp
have "(?L = {Mf cfs}) = (?L ⊆ {Mf cfs} ∧ Mf cfs ∈ ?L)" by blast
also have "?L ⊆ {Mf cfs} = (∀ dfs. ?f dfs ⟶ Mf dfs = Mf cfs)" by blast
also have "… = (∀ y. ?F y ⟶ y = Cfs)" (is "?left = ?right")
proof (rule; intro allI impI)
fix Dfs
assume *: ?left and F: "?F Dfs"
from X_to_x[of Dfs] obtain dfs where [transfer_rule]: "MF_Rel dfs Dfs" by auto
from F[untransferred] have f: "?f dfs" .
from *[rule_format, OF f] have eq: "Mf dfs = Mf cfs" by simp
have "(Mf dfs = Mf cfs) = (Dfs = Cfs)" by (transfer_prover_start, transfer_step+, simp)
thus "Dfs = Cfs" using eq by simp
next
fix dfs
assume *: ?right and f: "?f dfs"
from left_total_MF_Rel obtain Dfs where
rel[transfer_rule]: "MF_Rel dfs Dfs" unfolding left_total_def by blast
have "?F Dfs" by (transfer, rule f)
from *[rule_format, OF this] have eq: "Dfs = Cfs" .
have "(Mf dfs = Mf cfs) = (Dfs = Cfs)" by (transfer_prover_start, transfer_step+, simp)
thus "Mf dfs = Mf cfs" using eq by simp
qed
also have "Mf cfs ∈ ?L = (∃ dfs. ?f dfs ∧ Mf cfs = Mf dfs)" by auto
also have "… = ?F Cfs" unfolding fF
proof
assume "∃ dfs. ?f dfs ∧ Mf cfs = Mf dfs"
then obtain dfs where f: "?f dfs" and id: "Mf dfs = Mf cfs" by auto
from f have "?f (Mf dfs)" by simp
from this[unfolded id] show "?f cfs" by simp
qed blast
finally show "(?L = {Mf cfs}) = (?R = {Cfs})" by auto
qed
qed
end
context begin
private lemma 1: "poly_mod_type TYPE('a :: nontriv) m = (m = int CARD('a))"
and 2: "class.nontriv TYPE('a) = (CARD('a) ≥ 2)"
unfolding poly_mod_type_def class.prime_card_def class.nontriv_def poly_mod_prime_type_def by auto
private lemma 3: "poly_mod_prime_type TYPE('b) m = (m = int CARD('b))"
and 4: "class.prime_card TYPE('b :: prime_card) = prime CARD('b :: prime_card)"
unfolding poly_mod_type_def class.prime_card_def class.nontriv_def poly_mod_prime_type_def by auto
lemmas poly_mod_type_simps = 1 2 3 4
end
lemma remove_duplicate_premise: "(PROP P ⟹ PROP P ⟹ PROP Q) ≡ (PROP P ⟹ PROP Q)" (is "?l ≡ ?r")
proof (intro Pure.equal_intr_rule)
assume p: "PROP P" and ppq: "PROP ?l"
from ppq[OF p p] show "PROP Q".
next
assume p: "PROP P" and pq: "PROP ?r"
from pq[OF p] show "PROP Q".
qed
context poly_mod_prime begin
lemma type_to_set:
assumes type_def: "∃(Rep :: 'b ⇒ int) Abs. type_definition Rep Abs {0 ..< p :: int}"
shows "class.prime_card (TYPE('b))" (is ?a) and "p = int CARD('b)" (is ?b)
proof -
from prime have p2: "p ≥ 2" by (rule prime_ge_2_int)
from type_def obtain rep :: "'b ⇒ int" and abs :: "int ⇒ 'b" where t: "type_definition rep abs {0 ..< p}" by auto
have "card (UNIV :: 'b set) = card {0 ..< p}" using t by (rule type_definition.card)
also have "… = p" using p2 by auto
finally show ?b ..
then show ?a unfolding class.prime_card_def using prime p2 by auto
qed
end
lemmas (in poly_mod_type) prime_elem_m_dvdm_multD = prime_elem_dvd_multD
[where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_2) prime_elem_m_dvdm_multD = poly_mod_type.prime_elem_m_dvdm_multD
[unfolded poly_mod_type_simps, internalize_sort "'a :: nontriv", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemmas(in poly_mod_prime_type) degree_m_mult_eq = degree_mult_eq
[where 'a = "'a mod_ring", untransferred]
lemmas(in poly_mod_prime) degree_m_mult_eq = poly_mod_prime_type.degree_m_mult_eq
[unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemma(in poly_mod_prime) irreducible⇩d_lifting:
assumes n: "n ≠ 0"
and deg: "poly_mod.degree_m (p^n) f = degree_m f"
and irr: "irreducible⇩d_m f"
shows "poly_mod.irreducible⇩d_m (p^n) f"
proof -
interpret q: poly_mod_2 "p^n" unfolding poly_mod_2_def using n m1 by auto
show "q.irreducible⇩d_m f"
proof (rule q.irreducible⇩d_mI)
from deg irr show "q.degree_m f > 0" by (auto elim: irreducible⇩d_mE)
then have pdeg_f: "degree_m f ≠ 0" by (simp add: deg)
note pMp_Mp = Mp_Mp_pow_is_Mp[OF n m1]
fix g h
assume deg_g: "degree g < q.degree_m f" and deg_h: "degree h < q.degree_m f"
and eq: "q.eq_m f (g * h)"
from eq have p_f: "f =m (g * h)" using pMp_Mp by metis
have "¬g =m 0" and "¬h =m 0"
apply (metis degree_0 mult_zero_left Mp_0 p_f pdeg_f poly_mod.mult_Mp(1))
by (metis degree_0 mult_eq_0_iff Mp_0 mult_Mp(2) p_f pdeg_f)
note [simp] = degree_m_mult_eq[OF this]
from degree_m_le[of g] deg_g
have 2: "degree_m g < degree_m f" by (fold deg, auto)
from degree_m_le[of h] deg_h
have 3: "degree_m h < degree_m f" by (fold deg, auto)
from irreducible⇩d_mD(2)[OF irr 2 3] p_f
show False by auto
qed
qed
lemmas (in poly_mod_prime_type) mset_factors_exist =
mset_factors_exist[where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_prime) mset_factors_exist = poly_mod_prime_type.mset_factors_exist
[unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemmas (in poly_mod_prime_type) mset_factors_unique =
mset_factors_unique[where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_prime) mset_factors_unique = poly_mod_prime_type.mset_factors_unique
[unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemmas (in poly_mod_prime_type) prime_elem_iff_irreducible =
prime_elem_iff_irreducible[where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_prime) prime_elem_iff_irreducible[simp] = poly_mod_prime_type.prime_elem_iff_irreducible
[unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemmas (in poly_mod_prime_type) irreducible_connect =
irreducible_connect_field[where 'a = "'a mod_ring", untransferred]
lemmas (in poly_mod_prime) irreducible_connect[simp] = poly_mod_prime_type.irreducible_connect
[unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemmas (in poly_mod_prime_type) irreducible_degree =
irreducible_degree_field[where 'a = "'a mod_ring", untransferred]
lemmas (in poly_mod_prime) irreducible_degree = poly_mod_prime_type.irreducible_degree
[unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
end
Theory Karatsuba_Multiplication
subsection ‹Karatsuba's Multiplication Algorithm for Polynomials›
theory Karatsuba_Multiplication
imports
Polynomial_Interpolation.Missing_Polynomial
begin
lemma karatsuba_main_step: fixes f :: "'a :: comm_ring_1 poly"
assumes f: "f = monom_mult n f1 + f0" and g: "g = monom_mult n g1 + g0"
shows
"monom_mult (n + n) (f1 * g1) + (monom_mult n (f1 * g1 - (f1 - f0) * (g1 - g0) + f0 * g0) + f0 * g0) = f * g"
unfolding assms
by (auto simp: field_simps mult_monom monom_mult_def)
lemma karatsuba_single_sided: fixes f :: "'a :: comm_ring_1 poly"
assumes "f = monom_mult n f1 + f0"
shows "monom_mult n (f1 * g) + f0 * g = f * g"
unfolding assms by (auto simp: field_simps mult_monom monom_mult_def)
definition split_at :: "nat ⇒ 'a list ⇒ 'a list × 'a list" where
[code del]: "split_at n xs = (take n xs, drop n xs)"
lemma split_at_code[code]:
"split_at n [] = ([],[])"
"split_at n (x # xs) = (if n = 0 then ([], x # xs) else case split_at (n-1) xs of (bef,aft)
⇒ (x # bef, aft))"
unfolding split_at_def by (force, cases n, auto)
fun coeffs_minus :: "'a :: ab_group_add list ⇒ 'a list ⇒ 'a list" where
"coeffs_minus (x # xs) (y # ys) = ((x - y) # coeffs_minus xs ys)"
| "coeffs_minus xs [] = xs"
| "coeffs_minus [] ys = map uminus ys"
text ‹The following constant determines at which size we will switch to the standard
multiplication algorithm.›
definition karatsuba_lower_bound where [termination_simp]: "karatsuba_lower_bound = (7 :: nat)"
fun karatsuba_main :: "'a :: comm_ring_1 list ⇒ nat ⇒ 'a list ⇒ nat ⇒ 'a poly" where
"karatsuba_main f n g m = (if n ≤ karatsuba_lower_bound ∨ m ≤ karatsuba_lower_bound then
let ff = poly_of_list f in foldr (λa p. smult a ff + pCons 0 p) g 0
else let n2 = n div 2 in
if m > n2 then (case split_at n2 f of
(f0,f1) ⇒ case split_at n2 g of
(g0,g1) ⇒ let
p1 = karatsuba_main f1 (n - n2) g1 (m - n2);
p2 = karatsuba_main (coeffs_minus f1 f0) n2 (coeffs_minus g1 g0) n2;
p3 = karatsuba_main f0 n2 g0 n2
in monom_mult (n2 + n2) p1 + (monom_mult n2 (p1 - p2 + p3) + p3))
else case split_at n2 f of
(f0,f1) ⇒ let
p1 = karatsuba_main f1 (n - n2) g m;
p2 = karatsuba_main f0 n2 g m
in monom_mult n2 p1 + p2)"
declare karatsuba_main.simps[simp del]
lemma poly_of_list_split_at: assumes "split_at n f = (f0,f1)"
shows "poly_of_list f = monom_mult n (poly_of_list f1) + poly_of_list f0"
proof -
from assms have id: "f1 = drop n f" "f0 = take n f" unfolding split_at_def by auto
show ?thesis unfolding id
proof (rule poly_eqI)
fix i
show "coeff (poly_of_list f) i =
coeff (monom_mult n (poly_of_list (drop n f)) + poly_of_list (take n f)) i"
unfolding monom_mult_def coeff_monom_mult coeff_add poly_of_list_def coeff_Poly
by (cases "n ≤ i"; cases "i ≥ length f", auto simp: nth_default_nth nth_default_beyond)
qed
qed
lemma coeffs_minus: "poly_of_list (coeffs_minus f1 f0) = poly_of_list f1 - poly_of_list f0"
proof (rule poly_eqI, unfold poly_of_list_def coeff_diff coeff_Poly)
fix i
show "nth_default 0 (coeffs_minus f1 f0) i = nth_default 0 f1 i - nth_default 0 f0 i"
proof (induct f1 f0 arbitrary: i rule: coeffs_minus.induct)
case (1 x xs y ys)
thus ?case by (cases i, auto)
next
case (3 x xs)
thus ?case unfolding coeffs_minus.simps
by (subst nth_default_map_eq[of uminus 0 0], auto)
qed auto
qed
lemma karatsuba_main: "karatsuba_main f n g m = poly_of_list f * poly_of_list g"
proof (induct n arbitrary: f g m rule: less_induct)
case (less n f g m)
note simp[simp] = karatsuba_main.simps[of f n g m]
show ?case (is "?lhs = ?rhs")
proof (cases "(n ≤ karatsuba_lower_bound ∨ m ≤ karatsuba_lower_bound) = False")
case False
hence lhs: "?lhs = foldr (λa p. smult a (poly_of_list f) + pCons 0 p) g 0" by simp
have rhs: "?rhs = poly_of_list g * poly_of_list f" by simp
also have "… = foldr (λa p. smult a (poly_of_list f) + pCons 0 p) (strip_while ((=) 0) g) 0"
unfolding times_poly_def fold_coeffs_def poly_of_list_impl ..
also have "… = ?lhs" unfolding lhs
proof (induct g)
case (Cons x xs)
have "∀x∈set xs. x = 0 ⟹ foldr (λa p. smult a (Poly f) + pCons 0 p) xs 0 = 0"
by (induct xs, auto)
thus ?case using Cons by (auto simp: cCons_def Cons)
qed auto
finally show ?thesis by simp
next
case True
let ?n2 = "n div 2"
have "?n2 < n" "n - ?n2 < n" using True unfolding karatsuba_lower_bound_def by auto
note IH = less[OF this(1)] less[OF this(2)]
obtain f1 f0 where f: "split_at ?n2 f = (f0,f1)" by force
obtain g1 g0 where g: "split_at ?n2 g = (g0,g1)" by force
note fsplit = poly_of_list_split_at[OF f]
note gsplit = poly_of_list_split_at[OF g]
show "?lhs = ?rhs" unfolding simp Let_def f g split IH True if_False coeffs_minus
karatsuba_single_sided[OF fsplit] karatsuba_main_step[OF fsplit gsplit] by auto
qed
qed
definition karatsuba_mult_poly :: "'a :: comm_ring_1 poly ⇒ 'a poly ⇒ 'a poly" where
"karatsuba_mult_poly f g = (let ff = coeffs f; gg = coeffs g; n = length ff; m = length gg
in (if n ≤ karatsuba_lower_bound ∨ m ≤ karatsuba_lower_bound then if n ≤ m
then foldr (λa p. smult a g + pCons 0 p) ff 0
else foldr (λa p. smult a f + pCons 0 p) gg 0
else if n ≤ m
then karatsuba_main gg m ff n
else karatsuba_main ff n gg m))"
lemma karatsuba_mult_poly: "karatsuba_mult_poly f g = f * g"
proof -
note d = karatsuba_mult_poly_def Let_def
let ?len = "length (coeffs f) ≤ length (coeffs g)"
show ?thesis (is "?lhs = ?rhs")
proof (cases "length (coeffs f) ≤ karatsuba_lower_bound ∨ length (coeffs g) ≤ karatsuba_lower_bound")
case True note outer = this
show ?thesis
proof (cases ?len)
case True
with outer have "?lhs = foldr (λa p. smult a g + pCons 0 p) (coeffs f) 0" unfolding d by auto
also have "… = ?rhs" unfolding times_poly_def fold_coeffs_def by auto
finally show ?thesis .
next
case False
with outer have "?lhs = foldr (λa p. smult a f + pCons 0 p) (coeffs g) 0" unfolding d by auto
also have "… = g * f" unfolding times_poly_def fold_coeffs_def by auto
also have "… = ?rhs" by simp
finally show ?thesis .
qed
next
case False note outer = this
show ?thesis
proof (cases ?len)
case True
with outer have "?lhs = karatsuba_main (coeffs g) (length (coeffs g)) (coeffs f) (length (coeffs f))"
unfolding d by auto
also have "… = g * f" unfolding karatsuba_main by auto
also have "… = ?rhs" by auto
finally show ?thesis .
next
case False
with outer have "?lhs = karatsuba_main (coeffs f) (length (coeffs f)) (coeffs g) (length (coeffs g))"
unfolding d by auto
also have "… = ?rhs" unfolding karatsuba_main by auto
finally show ?thesis .
qed
qed
qed
lemma karatsuba_mult_poly_code_unfold[code_unfold]: "(*) = karatsuba_mult_poly"
by (intro ext, unfold karatsuba_mult_poly, auto)
text ‹The following declaration will resolve a race-conflict between @{thm karatsuba_mult_poly_code_unfold}
and @{thm monom_mult_unfold}.›
lemmas karatsuba_monom_mult_code_unfold[code_unfold] =
monom_mult_unfold[where f = "f :: 'a :: comm_ring_1 poly" for f, unfolded karatsuba_mult_poly_code_unfold]
end
Theory Polynomial_Record_Based
subsection ‹Record Based Version›
text ‹We provide an implementation for polynomials which may be parametrized
by the ring- or field-operations. These don't have to be type-based!›
subsubsection ‹Definitions›
theory Polynomial_Record_Based
imports
Arithmetic_Record_Based
Karatsuba_Multiplication
begin
context
fixes ops :: "'i arith_ops_record" (structure)
begin
private abbreviation (input) zero where "zero ≡ arith_ops_record.zero ops"
private abbreviation (input) one where "one ≡ arith_ops_record.one ops"
private abbreviation (input) plus where "plus ≡ arith_ops_record.plus ops"
private abbreviation (input) times where "times ≡ arith_ops_record.times ops"
private abbreviation (input) minus where "minus ≡ arith_ops_record.minus ops"
private abbreviation (input) uminus where "uminus ≡ arith_ops_record.uminus ops"
private abbreviation (input) divide where "divide ≡ arith_ops_record.divide ops"
private abbreviation (input) inverse where "inverse ≡ arith_ops_record.inverse ops"
private abbreviation (input) modulo where "modulo ≡ arith_ops_record.modulo ops"
private abbreviation (input) normalize where "normalize ≡ arith_ops_record.normalize ops"
private abbreviation (input) unit_factor where "unit_factor ≡ arith_ops_record.unit_factor ops"
private abbreviation (input) DP where "DP ≡ arith_ops_record.DP ops"
definition is_poly :: "'i list ⇒ bool" where
"is_poly xs ⟷ list_all DP xs ∧ no_trailing (HOL.eq zero) xs"
definition cCons_i :: "'i ⇒ 'i list ⇒ 'i list"
where
"cCons_i x xs = (if xs = [] ∧ x = zero then [] else x # xs)"
fun plus_poly_i :: "'i list ⇒ 'i list ⇒ 'i list" where
"plus_poly_i (x # xs) (y # ys) = cCons_i (plus x y) (plus_poly_i xs ys)"
| "plus_poly_i xs [] = xs"
| "plus_poly_i [] ys = ys"
definition uminus_poly_i :: "'i list ⇒ 'i list" where
[code_unfold]: "uminus_poly_i = map uminus"
fun minus_poly_i :: "'i list ⇒ 'i list ⇒ 'i list" where
"minus_poly_i (x # xs) (y # ys) = cCons_i (minus x y) (minus_poly_i xs ys)"
| "minus_poly_i xs [] = xs"
| "minus_poly_i [] ys = uminus_poly_i ys"
abbreviation (input) zero_poly_i :: "'i list" where
"zero_poly_i ≡ []"
definition one_poly_i :: "'i list" where
[code_unfold]: "one_poly_i = [one]"
definition smult_i :: "'i ⇒ 'i list ⇒ 'i list" where
"smult_i a pp = (if a = zero then [] else strip_while ((=) zero) (map (times a) pp))"
definition sdiv_i :: "'i list ⇒ 'i ⇒ 'i list" where
"sdiv_i pp a = (strip_while ((=) zero) (map (λ c. divide c a) pp))"
definition poly_of_list_i :: "'i list ⇒ 'i list" where
"poly_of_list_i = strip_while ((=) zero)"
fun coeffs_minus_i :: "'i list ⇒ 'i list ⇒ 'i list" where
"coeffs_minus_i (x # xs) (y # ys) = (minus x y # coeffs_minus_i xs ys)"
| "coeffs_minus_i xs [] = xs"
| "coeffs_minus_i [] ys = map uminus ys"
definition monom_mult_i :: "nat ⇒ 'i list ⇒ 'i list" where
"monom_mult_i n xs = (if xs = [] then xs else replicate n zero @ xs)"
fun karatsuba_main_i :: "'i list ⇒ nat ⇒ 'i list ⇒ nat ⇒ 'i list" where
"karatsuba_main_i f n g m = (if n ≤ karatsuba_lower_bound ∨ m ≤ karatsuba_lower_bound then
let ff = poly_of_list_i f in foldr (λa p. plus_poly_i (smult_i a ff) (cCons_i zero p)) g zero_poly_i
else let n2 = n div 2 in
if m > n2 then (case split_at n2 f of
(f0,f1) ⇒ case split_at n2 g of
(g0,g1) ⇒ let
p1 = karatsuba_main_i f1 (n - n2) g1 (m - n2);
p2 = karatsuba_main_i (coeffs_minus_i f1 f0) n2 (coeffs_minus_i g1 g0) n2;
p3 = karatsuba_main_i f0 n2 g0 n2
in plus_poly_i (monom_mult_i (n2 + n2) p1)
(plus_poly_i (monom_mult_i n2 (plus_poly_i (minus_poly_i p1 p2) p3)) p3))
else case split_at n2 f of
(f0,f1) ⇒ let
p1 = karatsuba_main_i f1 (n - n2) g m;
p2 = karatsuba_main_i f0 n2 g m
in plus_poly_i (monom_mult_i n2 p1) p2)"
definition times_poly_i :: "'i list ⇒ 'i list ⇒ 'i list" where
"times_poly_i f g ≡ (let n = length f; m = length g
in (if n ≤ karatsuba_lower_bound ∨ m ≤ karatsuba_lower_bound then if n ≤ m then
foldr (λa p. plus_poly_i (smult_i a g) (cCons_i zero p)) f zero_poly_i else
foldr (λa p. plus_poly_i (smult_i a f) (cCons_i zero p)) g zero_poly_i else
if n ≤ m then karatsuba_main_i g m f n else karatsuba_main_i f n g m))"
definition coeff_i :: "'i list ⇒ nat ⇒ 'i" where
"coeff_i = nth_default zero"
definition degree_i :: "'i list ⇒ nat" where
"degree_i pp ≡ length pp - 1"
definition lead_coeff_i :: "'i list ⇒ 'i" where
"lead_coeff_i pp = (case pp of [] ⇒ zero | _ ⇒ last pp)"
definition monic_i :: "'i list ⇒ bool" where
"monic_i pp = (lead_coeff_i pp = one)"
fun minus_poly_rev_list_i :: "'i list ⇒ 'i list ⇒ 'i list" where
"minus_poly_rev_list_i (x # xs) (y # ys) = (minus x y) # (minus_poly_rev_list_i xs ys)"
| "minus_poly_rev_list_i xs [] = xs"
| "minus_poly_rev_list_i [] (y # ys) = []"
fun divmod_poly_one_main_i :: "'i list ⇒ 'i list ⇒ 'i list
⇒ nat ⇒ 'i list × 'i list" where
"divmod_poly_one_main_i q r d (Suc n) = (let
a = hd r;
qqq = cCons_i a q;
rr = tl (if a = zero then r else minus_poly_rev_list_i r (map (times a) d))
in divmod_poly_one_main_i qqq rr d n)"
| "divmod_poly_one_main_i q r d 0 = (q,r)"
fun mod_poly_one_main_i :: "'i list ⇒ 'i list
⇒ nat ⇒ 'i list" where
"mod_poly_one_main_i r d (Suc n) = (let
a = hd r;
rr = tl (if a = zero then r else minus_poly_rev_list_i r (map (times a) d))
in mod_poly_one_main_i rr d n)"
| "mod_poly_one_main_i r d 0 = r"
definition pdivmod_monic_i :: "'i list ⇒ 'i list ⇒ 'i list × 'i list" where
"pdivmod_monic_i cf cg ≡ case
divmod_poly_one_main_i [] (rev cf) (rev cg) (1 + length cf - length cg)
of (q,r) ⇒ (poly_of_list_i q, poly_of_list_i (rev r))"
definition dupe_monic_i :: "'i list ⇒ 'i list ⇒ 'i list ⇒ 'i list ⇒ 'i list ⇒ 'i list × 'i list" where
"dupe_monic_i D H S T U = (case pdivmod_monic_i (times_poly_i T U) D of (Q,R) ⇒
(plus_poly_i (times_poly_i S U) (times_poly_i H Q), R))"
definition of_int_poly_i :: "int poly ⇒ 'i list" where
"of_int_poly_i f = map (arith_ops_record.of_int ops) (coeffs f)"
definition to_int_poly_i :: "'i list ⇒ int poly" where
"to_int_poly_i f = poly_of_list (map (arith_ops_record.to_int ops) f)"
definition dupe_monic_i_int :: "int poly ⇒ int poly ⇒ int poly ⇒ int poly ⇒ int poly ⇒ int poly × int poly" where
"dupe_monic_i_int D H S T = (let
d = of_int_poly_i D;
h = of_int_poly_i H;
s = of_int_poly_i S;
t = of_int_poly_i T
in (λ U. case dupe_monic_i d h s t (of_int_poly_i U) of
(D',H') ⇒ (to_int_poly_i D', to_int_poly_i H')))"
definition div_field_poly_i :: "'i list ⇒ 'i list ⇒ 'i list" where
"div_field_poly_i cf cg = (
if cg = [] then zero_poly_i
else let ilc = inverse (last cg); ch = map (times ilc) cg;
q = fst (divmod_poly_one_main_i [] (rev cf) (rev ch) (1 + length cf - length cg))
in poly_of_list_i ((map (times ilc) q)))"
definition mod_field_poly_i :: "'i list ⇒ 'i list ⇒ 'i list" where
"mod_field_poly_i cf cg = (
if cg = [] then cf
else let ilc = inverse (last cg); ch = map (times ilc) cg;
r = mod_poly_one_main_i (rev cf) (rev ch) (1 + length cf - length cg)
in poly_of_list_i (rev r))"
definition normalize_poly_i :: "'i list ⇒ 'i list" where
"normalize_poly_i xs = smult_i (inverse (unit_factor (lead_coeff_i xs))) xs"
definition unit_factor_poly_i :: "'i list ⇒ 'i list" where
"unit_factor_poly_i xs = cCons_i (unit_factor (lead_coeff_i xs)) []"
fun pderiv_main_i :: "'i ⇒ 'i list ⇒ 'i list" where
"pderiv_main_i f (x # xs) = cCons_i (times f x) (pderiv_main_i (plus f one) xs)"
| "pderiv_main_i f [] = []"
definition pderiv_i :: "'i list ⇒ 'i list" where
"pderiv_i xs = pderiv_main_i one (tl xs)"
definition dvd_poly_i :: "'i list ⇒ 'i list ⇒ bool" where
"dvd_poly_i xs ys = (∃ zs. is_poly zs ∧ ys = times_poly_i xs zs)"
definition irreducible_i :: "'i list ⇒ bool" where
"irreducible_i xs = (degree_i xs ≠ 0 ∧
(∀q r. is_poly q ⟶ is_poly r ⟶ degree_i q < degree_i xs ⟶ degree_i r < degree_i xs
⟶ xs ≠ times_poly_i q r))"
definition poly_ops :: "'i list arith_ops_record" where
"poly_ops ≡ Arith_Ops_Record
zero_poly_i
one_poly_i
plus_poly_i
times_poly_i
minus_poly_i
uminus_poly_i
div_field_poly_i
(λ _. [])
mod_field_poly_i
normalize_poly_i
unit_factor_poly_i
(λ i. if i = 0 then [] else [arith_ops_record.of_int ops i])
(λ _. 0)
is_poly"
definition gcd_poly_i :: "'i list ⇒ 'i list ⇒ 'i list" where
"gcd_poly_i = arith_ops.gcd_eucl_i poly_ops"
definition euclid_ext_poly_i :: "'i list ⇒ 'i list ⇒ ('i list × 'i list) × 'i list" where
"euclid_ext_poly_i = arith_ops.euclid_ext_i poly_ops"
definition separable_i :: "'i list ⇒ bool" where
"separable_i xs ≡ gcd_poly_i xs (pderiv_i xs) = one_poly_i"
end
subsubsection ‹Properties›
definition pdivmod_monic :: "'a::comm_ring_1 poly ⇒ 'a poly ⇒ 'a poly × 'a poly" where
"pdivmod_monic f g ≡ let cg = coeffs g; cf = coeffs f;
(q, r) = divmod_poly_one_main_list [] (rev cf) (rev cg) (1 + length cf - length cg)
in (poly_of_list q, poly_of_list (rev r))"
lemma coeffs_smult': "coeffs (smult a p) = (if a = 0 then [] else strip_while ((=) 0) (map (Groups.times a) (coeffs p)))"
by (simp add: coeffs_map_poly smult_conv_map_poly)
lemma coeffs_sdiv: "coeffs (sdiv_poly p a) = (strip_while ((=) 0) (map (λ x. x div a) (coeffs p)))"
unfolding sdiv_poly_def by (rule coeffs_map_poly)
lifting_forget poly.lifting
context ring_ops
begin
definition poly_rel :: "'i list ⇒ 'a poly ⇒ bool" where
"poly_rel x x' ⟷ list_all2 R x (coeffs x')"
lemma right_total_poly_rel[transfer_rule]:
"right_total poly_rel"
using list.right_total_rel[of R] right_total unfolding poly_rel_def right_total_def by auto
lemma poly_rel_inj: "poly_rel x y ⟹ poly_rel x z ⟹ y = z"
using list.bi_unique_rel[OF bi_unique] unfolding poly_rel_def coeffs_eq_iff bi_unique_def by auto
lemma bi_unique_poly_rel[transfer_rule]: "bi_unique poly_rel"
using list.bi_unique_rel[OF bi_unique] unfolding poly_rel_def bi_unique_def coeffs_eq_iff by auto
lemma Domainp_is_poly [transfer_domain_rule]:
"Domainp poly_rel = is_poly ops"
unfolding poly_rel_def [abs_def] is_poly_def [abs_def]
proof (intro ext iffI, unfold Domainp_iff)
note DPR = fun_cong [OF list.Domainp_rel [of R, unfolded DPR],
unfolded Domainp_iff]
let ?no_trailing = "no_trailing (HOL.eq zero)"
fix xs
have no_trailing: "no_trailing (HOL.eq 0) xs' ⟷ ?no_trailing xs"
if "list_all2 R xs xs'" for xs'
proof (cases xs rule: rev_cases)
case Nil
with that show ?thesis
by simp
next
case (snoc ys y)
with that have "xs' ≠ []"
by auto
then obtain ys' y' where "xs' = ys' @ [y']"
by (cases xs' rule: rev_cases) simp_all
with that snoc show ?thesis
by simp (meson bi_unique bi_unique_def zero)
qed
let ?DPR = "arith_ops_record.DP ops"
{
assume "∃x'. list_all2 R xs (coeffs x')"
then obtain xs' where *: "list_all2 R xs (coeffs xs')" by auto
with DPR [of xs] have "list_all ?DPR xs" by auto
then show "list_all ?DPR xs ∧ ?no_trailing xs"
using no_trailing [OF *] by simp
}
{
assume "list_all ?DPR xs ∧ ?no_trailing xs"
with DPR [of xs] obtain xs' where *: "list_all2 R xs xs'" and "?no_trailing xs"
by auto
from no_trailing [OF *] this(2) have "no_trailing (HOL.eq 0) xs'"
by simp
hence "coeffs (poly_of_list xs') = xs'" unfolding poly_of_list_impl by auto
with * show "∃x'. list_all2 R xs (coeffs x')" by metis
}
qed
lemma poly_rel_zero[transfer_rule]: "poly_rel zero_poly_i 0"
unfolding poly_rel_def by auto
lemma poly_rel_one[transfer_rule]: "poly_rel (one_poly_i ops) 1"
unfolding poly_rel_def one_poly_i_def by (simp add: one)
lemma poly_rel_cCons[transfer_rule]: "(R ===> list_all2 R ===> list_all2 R) (cCons_i ops) cCons"
unfolding cCons_i_def[abs_def] cCons_def[abs_def]
by transfer_prover
lemma poly_rel_pCons[transfer_rule]: "(R ===> poly_rel ===> poly_rel) (cCons_i ops) pCons"
unfolding rel_fun_def poly_rel_def coeffs_pCons_eq_cCons cCons_def[symmetric]
using poly_rel_cCons[unfolded rel_fun_def] by auto
lemma poly_rel_eq[transfer_rule]: "(poly_rel ===> poly_rel ===> (=)) (=) (=)"
unfolding poly_rel_def[abs_def] coeffs_eq_iff[abs_def] rel_fun_def
by (metis bi_unique bi_uniqueDl bi_uniqueDr list.bi_unique_rel)
lemma poly_rel_plus[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel) (plus_poly_i ops) (+)"
proof (intro rel_funI)
fix x1 y1 x2 y2
assume "poly_rel x1 x2" and "poly_rel y1 y2"
thus "poly_rel (plus_poly_i ops x1 y1) (x2 + y2)"
unfolding poly_rel_def coeffs_eq_iff coeffs_plus_eq_plus_coeffs
proof (induct x1 y1 arbitrary: x2 y2 rule: plus_poly_i.induct)
case (1 x1 xs1 y1 ys1 X2 Y2)
from 1(2) obtain x2 xs2 where X2: "coeffs X2 = x2 # coeffs xs2"
by (cases X2, auto simp: cCons_def split: if_splits)
from 1(3) obtain y2 ys2 where Y2: "coeffs Y2 = y2 # coeffs ys2"
by (cases Y2, auto simp: cCons_def split: if_splits)
from 1(2) 1(3) have [transfer_rule]: "R x1 x2" "R y1 y2"
and *: "list_all2 R xs1 (coeffs xs2)" "list_all2 R ys1 (coeffs ys2)" unfolding X2 Y2 by auto
note [transfer_rule] = 1(1)[OF *]
show ?case unfolding X2 Y2 by simp transfer_prover
next
case (2 xs1 xs2 ys2)
thus ?case by (cases "coeffs xs2", auto)
next
case (3 xs2 y1 ys1 Y2)
thus ?case by (cases Y2, auto simp: cCons_def)
qed
qed
lemma poly_rel_uminus[transfer_rule]: "(poly_rel ===> poly_rel) (uminus_poly_i ops) Groups.uminus"
proof (intro rel_funI)
fix x y
assume "poly_rel x y"
hence [transfer_rule]: "list_all2 R x (coeffs y)" unfolding poly_rel_def .
show "poly_rel (uminus_poly_i ops x) (-y)"
unfolding poly_rel_def coeffs_uminus uminus_poly_i_def by transfer_prover
qed
lemma poly_rel_minus[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel) (minus_poly_i ops) (-)"
proof (intro rel_funI)
fix x1 y1 x2 y2
assume "poly_rel x1 x2" and "poly_rel y1 y2"
thus "poly_rel (minus_poly_i ops x1 y1) (x2 - y2)"
unfolding diff_conv_add_uminus
unfolding poly_rel_def coeffs_eq_iff coeffs_plus_eq_plus_coeffs coeffs_uminus
proof (induct x1 y1 arbitrary: x2 y2 rule: minus_poly_i.induct)
case (1 x1 xs1 y1 ys1 X2 Y2)
from 1(2) obtain x2 xs2 where X2: "coeffs X2 = x2 # coeffs xs2"
by (cases X2, auto simp: cCons_def split: if_splits)
from 1(3) obtain y2 ys2 where Y2: "coeffs Y2 = y2 # coeffs ys2"
by (cases Y2, auto simp: cCons_def split: if_splits)
from 1(2) 1(3) have [transfer_rule]: "R x1 x2" "R y1 y2"
and *: "list_all2 R xs1 (coeffs xs2)" "list_all2 R ys1 (coeffs ys2)" unfolding X2 Y2 by auto
note [transfer_rule] = 1(1)[OF *]
show ?case unfolding X2 Y2 by simp transfer_prover
next
case (2 xs1 xs2 ys2)
thus ?case by (cases "coeffs xs2", auto)
next
case (3 xs2 y1 ys1 Y2)
from 3(1) have id0: "coeffs ys1 = coeffs 0" by (cases ys1, auto)
have id1: "minus_poly_i ops [] (xs2 # y1) = uminus_poly_i ops (xs2 # y1)" by simp
from 3(2) have [transfer_rule]: "poly_rel (xs2 # y1) Y2" unfolding poly_rel_def by simp
show ?case unfolding id0 id1 coeffs_uminus[symmetric] coeffs_plus_eq_plus_coeffs[symmetric]
poly_rel_def[symmetric] by simp transfer_prover
qed
qed
lemma poly_rel_smult[transfer_rule]: "(R ===> poly_rel ===> poly_rel) (smult_i ops) smult"
unfolding rel_fun_def poly_rel_def coeffs_smult' smult_i_def
proof (intro allI impI, goal_cases)
case (1 x y xs ys)
note [transfer_rule] = 1
show ?case by transfer_prover
qed
lemma poly_rel_coeffs[transfer_rule]: "(poly_rel ===> list_all2 R) (λ x. x) coeffs"
unfolding rel_fun_def poly_rel_def by auto
lemma poly_rel_poly_of_list[transfer_rule]: "(list_all2 R ===> poly_rel) (poly_of_list_i ops) poly_of_list"
unfolding rel_fun_def poly_of_list_i_def poly_rel_def poly_of_list_impl
proof (intro allI impI, goal_cases)
case (1 x y)
note [transfer_rule] = this
show ?case by transfer_prover
qed
lemma poly_rel_monom_mult[transfer_rule]:
"((=) ===> poly_rel ===> poly_rel) (monom_mult_i ops) monom_mult"
unfolding rel_fun_def monom_mult_i_def poly_rel_def monom_mult_code Let_def
proof (auto, goal_cases)
case (1 x xs y)
show ?case by (induct x, auto simp: 1(3) zero)
qed
declare karatsuba_main_i.simps[simp del]
lemma list_rel_coeffs_minus_i: assumes "list_all2 R x1 x2" "list_all2 R y1 y2"
shows "list_all2 R (coeffs_minus_i ops x1 y1) (coeffs_minus x2 y2)"
proof -
note simps = coeffs_minus_i.simps coeffs_minus.simps
show ?thesis using assms
proof (induct x1 y1 arbitrary: x2 y2 rule: coeffs_minus_i.induct)
case (1 x xs y ys)
from 1(2-) obtain Y Ys where y2: "y2 = Y # Ys" unfolding list_all2_conv_all_nth by (cases y2, auto)
with 1(2-) have y: "R y Y" "list_all2 R ys Ys" by auto
from 1(2-) obtain X Xs where x2: "x2 = X # Xs" unfolding list_all2_conv_all_nth by (cases x2, auto)
with 1(2-) have x: "R x X" "list_all2 R xs Xs" by auto
from 1(1)[OF x(2) y(2)] x(1) y(1)
show ?case unfolding x2 y2 simps using minus[unfolded rel_fun_def] by auto
next
case (3 y ys)
from 3 have x2: "x2 = []" by auto
from 3 obtain Y Ys where y2: "y2 = Y # Ys" unfolding list_all2_conv_all_nth by (cases y2, auto)
obtain y1 where y1: "y # ys = y1" by auto
show ?case unfolding y2 simps x2 unfolding y2[symmetric] list_all2_map2 list_all2_map1
using 3(2) unfolding y1 using uminus[unfolded rel_fun_def]
unfolding list_all2_conv_all_nth by auto
qed auto
qed
lemma poly_rel_karatsuba_main: "list_all2 R x1 x2 ⟹ list_all2 R y1 y2 ⟹
poly_rel (karatsuba_main_i ops x1 n y1 m) (karatsuba_main x2 n y2 m)"
proof (induct n arbitrary: x1 y1 x2 y2 m rule: less_induct)
case (less n f g F G m)
note simp[simp] = karatsuba_main.simps[of F n G m] karatsuba_main_i.simps[of ops f n g m]
note IH = less(1)
note rel[transfer_rule] = less(2-3)
show ?case (is "poly_rel ?lhs ?rhs")
proof (cases "(n ≤ karatsuba_lower_bound ∨ m ≤ karatsuba_lower_bound) = False")
case False
from False
have lhs: "?lhs = foldr (λa p. plus_poly_i ops (smult_i ops a (poly_of_list_i ops f))
(cCons_i ops zero p)) g []" by simp
from False have rhs: "?rhs = foldr (λa p. smult a (poly_of_list F) + pCons 0 p) G 0" by simp
show ?thesis unfolding lhs rhs by transfer_prover
next
case True note * = this
let ?n2 = "n div 2"
have "?n2 < n" "n - ?n2 < n" using True unfolding karatsuba_lower_bound_def by auto
note IH = IH[OF this(1)] IH[OF this(2)]
obtain f1 f0 where f: "split_at ?n2 f = (f0,f1)" by force
obtain g1 g0 where g: "split_at ?n2 g = (g0,g1)" by force
obtain F1 F0 where F: "split_at ?n2 F = (F0,F1)" by force
obtain G1 G0 where G: "split_at ?n2 G = (G0,G1)" by force
from rel f F have relf[transfer_rule]: "list_all2 R f0 F0" "list_all2 R f1 F1"
unfolding split_at_def by auto
from rel g G have relg[transfer_rule]: "list_all2 R g0 G0" "list_all2 R g1 G1"
unfolding split_at_def by auto
show ?thesis
proof (cases "?n2 < m")
case True
obtain p1 P1 where p1: "p1 = karatsuba_main_i ops f1 (n - n div 2) g1 (m - n div 2)"
"P1 = karatsuba_main F1 (n - n div 2) G1 (m - n div 2)" by auto
obtain p2 P2 where p2: "p2 = karatsuba_main_i ops (coeffs_minus_i ops f1 f0) (n div 2)
(coeffs_minus_i ops g1 g0) (n div 2)"
"P2 = karatsuba_main (coeffs_minus F1 F0) (n div 2)
(coeffs_minus G1 G0) (n div 2)" by auto
obtain p3 P3 where p3: "p3 = karatsuba_main_i ops f0 (n div 2) g0 (n div 2)"
"P3 = karatsuba_main F0 (n div 2) G0 (n div 2)" by auto
from * True have lhs: "?lhs = plus_poly_i ops (monom_mult_i ops (n div 2 + n div 2) p1)
(plus_poly_i ops
(monom_mult_i ops (n div 2)
(plus_poly_i ops (minus_poly_i ops p1 p2) p3)) p3)"
unfolding simp Let_def f g split p1 p2 p3 by auto
have [transfer_rule]: "poly_rel p1 P1" using IH(2)[OF relf(2) relg(2)] unfolding p1 .
have [transfer_rule]: "poly_rel p3 P3" using IH(1)[OF relf(1) relg(1)] unfolding p3 .
have [transfer_rule]: "poly_rel p2 P2" unfolding p2
by (rule IH(1)[OF list_rel_coeffs_minus_i list_rel_coeffs_minus_i], insert relf relg)
from True * have rhs: "?rhs = monom_mult (n div 2 + n div 2) P1 +
(monom_mult (n div 2) (P1 - P2 + P3) + P3)"
unfolding simp Let_def F G split p1 p2 p3 by auto
show ?thesis unfolding lhs rhs by transfer_prover
next
case False
obtain p1 P1 where p1: "p1 = karatsuba_main_i ops f1 (n - n div 2) g m"
"P1 = karatsuba_main F1 (n - n div 2) G m" by auto
obtain p2 P2 where p2: "p2 = karatsuba_main_i ops f0 (n div 2) g m"
"P2 = karatsuba_main F0 (n div 2) G m" by auto
from * False have lhs: "?lhs = plus_poly_i ops (monom_mult_i ops (n div 2) p1) p2"
unfolding simp Let_def f split p1 p2 by auto
from * False have rhs: "?rhs = monom_mult (n div 2) P1 + P2"
unfolding simp Let_def F split p1 p2 by auto
have [transfer_rule]: "poly_rel p1 P1" using IH(2)[OF relf(2) rel(2)] unfolding p1 .
have [transfer_rule]: "poly_rel p2 P2" using IH(1)[OF relf(1) rel(2)] unfolding p2 .
show ?thesis unfolding lhs rhs by transfer_prover
qed
qed
qed
lemma poly_rel_times[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel) (times_poly_i ops) ((*))"
proof (intro rel_funI)
fix x1 y1 x2 y2
assume x12[transfer_rule]: "poly_rel x1 x2" and y12 [transfer_rule]: "poly_rel y1 y2"
hence X12[transfer_rule]: "list_all2 R x1 (coeffs x2)" and Y12[transfer_rule]: "list_all2 R y1 (coeffs y2)"
unfolding poly_rel_def by auto
hence len: "length (coeffs x2) = length x1" "length (coeffs y2) = length y1"
unfolding list_all2_conv_all_nth by auto
let ?cond1 = "length x1 ≤ karatsuba_lower_bound ∨ length y1 ≤ karatsuba_lower_bound"
let ?cond2 = "length x1 ≤ length y1"
note d = karatsuba_mult_poly[symmetric] karatsuba_mult_poly_def Let_def
times_poly_i_def len if_True if_False
consider (TT) "?cond1 = True" "?cond2 = True" | (TF) "?cond1 = True" "?cond2 = False"
| (FT) "?cond1 = False" "?cond2 = True" | (FF) "?cond1 = False" "?cond2 = False" by auto
thus "poly_rel (times_poly_i ops x1 y1) (x2 * y2)"
proof (cases)
case TT
show ?thesis unfolding d TT
unfolding poly_rel_def coeffs_eq_iff times_poly_def times_poly_i_def fold_coeffs_def
by transfer_prover
next
case TF
show ?thesis unfolding d TF
unfolding poly_rel_def coeffs_eq_iff times_poly_def times_poly_i_def fold_coeffs_def
by transfer_prover
next
case FT
show ?thesis unfolding d FT
by (rule poly_rel_karatsuba_main[OF Y12 X12])
next
case FF
show ?thesis unfolding d FF
by (rule poly_rel_karatsuba_main[OF X12 Y12])
qed
qed
lemma poly_rel_coeff[transfer_rule]: "(poly_rel ===> (=) ===> R) (coeff_i ops) coeff"
unfolding poly_rel_def rel_fun_def coeff_i_def nth_default_coeffs_eq[symmetric]
proof (intro allI impI, clarify)
fix x y n
assume [transfer_rule]: "list_all2 R x (coeffs y)"
show "R (nth_default zero x n) (nth_default 0 (coeffs y) n)" by transfer_prover
qed
lemma poly_rel_degree[transfer_rule]: "(poly_rel ===> (=)) degree_i degree"
unfolding poly_rel_def rel_fun_def degree_i_def degree_eq_length_coeffs
by (simp add: list_all2_lengthD)
lemma lead_coeff_i_def': "lead_coeff_i ops x = (coeff_i ops) x (degree_i x)"
unfolding lead_coeff_i_def degree_i_def coeff_i_def
proof (cases x, auto, goal_cases)
case (1 a xs)
hence id: "last xs = last (a # xs)" by auto
show ?case unfolding id by (subst last_conv_nth_default, auto)
qed
lemma poly_rel_lead_coeff[transfer_rule]: "(poly_rel ===> R) (lead_coeff_i ops) lead_coeff"
unfolding lead_coeff_i_def' [abs_def] by transfer_prover
lemma poly_rel_minus_poly_rev_list[transfer_rule]:
"(list_all2 R ===> list_all2 R ===> list_all2 R) (minus_poly_rev_list_i ops) minus_poly_rev_list"
proof (intro rel_funI, goal_cases)
case (1 x1 x2 y1 y2)
thus ?case
proof (induct x1 y1 arbitrary: x2 y2 rule: minus_poly_rev_list_i.induct)
case (1 x1 xs1 y1 ys1 X2 Y2)
from 1(2) obtain x2 xs2 where X2: "X2 = x2 # xs2" by (cases X2, auto)
from 1(3) obtain y2 ys2 where Y2: "Y2 = y2 # ys2" by (cases Y2, auto)
from 1(2) 1(3) have [transfer_rule]: "R x1 x2" "R y1 y2"
and *: "list_all2 R xs1 xs2" "list_all2 R ys1 ys2" unfolding X2 Y2 by auto
note [transfer_rule] = 1(1)[OF *]
show ?case unfolding X2 Y2 by (simp, intro conjI, transfer_prover+)
next
case (2 xs1 xs2 ys2)
thus ?case by (cases xs2, auto)
next
case (3 xs2 y1 ys1 Y2)
thus ?case by (cases Y2, auto)
qed
qed
lemma divmod_poly_one_main_i: assumes len: "n ≤ length Y" and rel: "list_all2 R x X" "list_all2 R y Y"
"list_all2 R z Z" and n: "n = N"
shows "rel_prod (list_all2 R) (list_all2 R) (divmod_poly_one_main_i ops x y z n)
(divmod_poly_one_main_list X Y Z N)"
using len rel unfolding n
proof (induct N arbitrary: x X y Y z Z)
case (Suc n x X y Y z Z)
from Suc(2,4) have [transfer_rule]: "R (hd y) (hd Y)" by (cases y; cases Y, auto)
note [transfer_rule] = Suc(3-5)
have id: "?case = (rel_prod (list_all2 R) (list_all2 R)
(divmod_poly_one_main_i ops (cCons_i ops (hd y) x)
(tl (if hd y = zero then y else minus_poly_rev_list_i ops y (map (times (hd y)) z))) z n)
(divmod_poly_one_main_list (cCons (hd Y) X)
(tl (if hd Y = 0 then Y else minus_poly_rev_list Y (map ((*) (hd Y)) Z))) Z n))"
by (simp add: Let_def)
show ?case unfolding id
proof (rule Suc(1), goal_cases)
case 1
show ?case using Suc(2) by simp
qed (transfer_prover+)
qed simp
lemma mod_poly_one_main_i: assumes len: "n ≤ length X" and rel: "list_all2 R x X" "list_all2 R y Y"
and n: "n = N"
shows "list_all2 R (mod_poly_one_main_i ops x y n)
(mod_poly_one_main_list X Y N)"
using len rel unfolding n
proof (induct N arbitrary: x X y Y)
case (Suc n y Y z Z)
from Suc(2,3) have [transfer_rule]: "R (hd y) (hd Y)" by (cases y; cases Y, auto)
note [transfer_rule] = Suc(3-4)
have id: "?case = (list_all2 R
(mod_poly_one_main_i ops
(tl (if hd y = zero then y else minus_poly_rev_list_i ops y (map (times (hd y)) z))) z n)
(mod_poly_one_main_list
(tl (if hd Y = 0 then Y else minus_poly_rev_list Y (map ((*) (hd Y)) Z))) Z n))"
by (simp add: Let_def)
show ?case unfolding id
proof (rule Suc(1), goal_cases)
case 1
show ?case using Suc(2) by simp
qed (transfer_prover+)
qed simp
lemma poly_rel_dvd[transfer_rule]: "(poly_rel ===> poly_rel ===> (=)) (dvd_poly_i ops) (dvd)"
unfolding dvd_poly_i_def[abs_def] dvd_def[abs_def]
by (transfer_prover_start, transfer_step+, auto)
lemma poly_rel_monic[transfer_rule]: "(poly_rel ===> (=)) (monic_i ops) monic"
unfolding monic_i_def lead_coeff_i_def' by transfer_prover
lemma poly_rel_pdivmod_monic: assumes mon: "monic Y"
and x: "poly_rel x X" and y: "poly_rel y Y"
shows "rel_prod poly_rel poly_rel (pdivmod_monic_i ops x y) (pdivmod_monic X Y)"
proof -
note [transfer_rule] = x y
note listall = this[unfolded poly_rel_def]
note defs = pdivmod_monic_def pdivmod_monic_i_def Let_def
from mon obtain k where len: "length (coeffs Y) = Suc k" unfolding poly_rel_def list_all2_iff
by (cases "coeffs Y", auto)
have [transfer_rule]:
"rel_prod (list_all2 R) (list_all2 R)
(divmod_poly_one_main_i ops [] (rev x) (rev y) (1 + length x - length y))
(divmod_poly_one_main_list [] (rev (coeffs X)) (rev (coeffs Y)) (1 + length (coeffs X) - length (coeffs Y)))"
by (rule divmod_poly_one_main_i, insert x y listall, auto, auto simp: poly_rel_def list_all2_iff len)
show ?thesis unfolding defs by transfer_prover
qed
lemma ring_ops_poly: "ring_ops (poly_ops ops) poly_rel"
by (unfold_locales, auto simp: poly_ops_def
bi_unique_poly_rel
right_total_poly_rel
poly_rel_times
poly_rel_zero
poly_rel_one
poly_rel_minus
poly_rel_uminus
poly_rel_plus
poly_rel_eq
Domainp_is_poly)
end
context idom_ops
begin
lemma poly_rel_pderiv [transfer_rule]: "(poly_rel ===> poly_rel) (pderiv_i ops) pderiv"
proof (intro rel_funI, unfold poly_rel_def coeffs_pderiv_code pderiv_i_def pderiv_coeffs_def)
fix xs xs'
assume "list_all2 R xs (coeffs xs')"
then obtain ys ys' y y' where id: "tl xs = ys" "tl (coeffs xs') = ys'" "one = y" "1 = y'" and
R: "list_all2 R ys ys'" "R y y'"
by (cases xs; cases "coeffs xs'"; auto simp: one)
show "list_all2 R (pderiv_main_i ops one (tl xs))
(pderiv_coeffs_code 1 (tl (coeffs xs')))"
unfolding id using R
proof (induct ys ys' arbitrary: y y' rule: list_all2_induct)
case (Cons x xs x' xs' y y')
note [transfer_rule] = Cons(1,2,4)
have "R (plus y one) (y' + 1)" by transfer_prover
note [transfer_rule] = Cons(3)[OF this]
show ?case by (simp, transfer_prover)
qed simp
qed
lemma poly_rel_irreducible[transfer_rule]: "(poly_rel ===> (=)) (irreducible_i ops) irreducible⇩d"
unfolding irreducible_i_def[abs_def] irreducible⇩d_def[abs_def]
by (transfer_prover_start, transfer_step+, auto)
lemma idom_ops_poly: "idom_ops (poly_ops ops) poly_rel"
using ring_ops_poly unfolding ring_ops_def idom_ops_def by auto
end
context idom_divide_ops
begin
lemma poly_rel_sdiv[transfer_rule]: "(poly_rel ===> R ===> poly_rel) (sdiv_i ops) sdiv_poly"
unfolding rel_fun_def poly_rel_def coeffs_sdiv sdiv_i_def
proof (intro allI impI, goal_cases)
case (1 x y xs ys)
note [transfer_rule] = 1
show ?case by transfer_prover
qed
end
context field_ops
begin
lemma poly_rel_div[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel)
(div_field_poly_i ops) (div)"
proof (intro rel_funI, goal_cases)
case (1 x X y Y)
note [transfer_rule] = this
note listall = this[unfolded poly_rel_def]
note defs = div_field_poly_impl div_field_poly_impl_def div_field_poly_i_def Let_def
show ?case
proof (cases "y = []")
case True
with 1(2) have nil: "coeffs Y = []" unfolding poly_rel_def by auto
show ?thesis unfolding defs True nil poly_rel_def by auto
next
case False
from append_butlast_last_id[OF False] obtain ys yl where y: "y = ys @ [yl]" by metis
from False listall have "coeffs Y ≠ []" by auto
from append_butlast_last_id[OF this] obtain Ys Yl where Y: "coeffs Y = Ys @ [Yl]" by metis
from listall have [transfer_rule]: "R yl Yl" by (simp add: y Y)
have id: "last (coeffs Y) = Yl" "last (y) = yl"
"⋀ t e. (if y = [] then t else e) = e"
"⋀ t e. (if coeffs Y = [] then t else e) = e" unfolding y Y by auto
have [transfer_rule]: "(rel_prod (list_all2 R) (list_all2 R))
(divmod_poly_one_main_i ops [] (rev x) (rev (map (times (inverse yl)) y))
(1 + length x - length y))
(divmod_poly_one_main_list [] (rev (coeffs X))
(rev (map ((*) (Fields.inverse Yl)) (coeffs Y)))
(1 + length (coeffs X) - length (coeffs Y)))"
proof (rule divmod_poly_one_main_i, goal_cases)
case 5
from listall show ?case by (simp add: list_all2_lengthD)
next
case 1
from listall show ?case by (simp add: list_all2_lengthD Y)
qed transfer_prover+
show ?thesis unfolding defs id by transfer_prover
qed
qed
lemma poly_rel_mod[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel)
(mod_field_poly_i ops) (mod)"
proof (intro rel_funI, goal_cases)
case (1 x X y Y)
note [transfer_rule] = this
note listall = this[unfolded poly_rel_def]
note defs = mod_poly_code mod_field_poly_i_def Let_def
show ?case
proof (cases "y = []")
case True
with 1(2) have nil: "coeffs Y = []" unfolding poly_rel_def by auto
show ?thesis unfolding defs True nil poly_rel_def by (simp add: listall)
next
case False
from append_butlast_last_id[OF False] obtain ys yl where y: "y = ys @ [yl]" by metis
from False listall have "coeffs Y ≠ []" by auto
from append_butlast_last_id[OF this] obtain Ys Yl where Y: "coeffs Y = Ys @ [Yl]" by metis
from listall have [transfer_rule]: "R yl Yl" by (simp add: y Y)
have id: "last (coeffs Y) = Yl" "last (y) = yl"
"⋀ t e. (if y = [] then t else e) = e"
"⋀ t e. (if coeffs Y = [] then t else e) = e" unfolding y Y by auto
have [transfer_rule]: "list_all2 R
(mod_poly_one_main_i ops (rev x) (rev (map (times (inverse yl)) y))
(1 + length x - length y))
(mod_poly_one_main_list (rev (coeffs X))
(rev (map ((*) (Fields.inverse Yl)) (coeffs Y)))
(1 + length (coeffs X) - length (coeffs Y)))"
proof (rule mod_poly_one_main_i, goal_cases)
case 4
from listall show ?case by (simp add: list_all2_lengthD)
next
case 1
from listall show ?case by (simp add: list_all2_lengthD Y)
qed transfer_prover+
show ?thesis unfolding defs id by transfer_prover
qed
qed
lemma poly_rel_normalize [transfer_rule]: "(poly_rel ===> poly_rel)
(normalize_poly_i ops) Rings.normalize"
unfolding normalize_poly_old_def normalize_poly_i_def lead_coeff_i_def'
by transfer_prover
lemma poly_rel_unit_factor [transfer_rule]: "(poly_rel ===> poly_rel)
(unit_factor_poly_i ops) Rings.unit_factor"
unfolding unit_factor_poly_def unit_factor_poly_i_def lead_coeff_i_def'
unfolding monom_0 by transfer_prover
lemma idom_divide_ops_poly: "idom_divide_ops (poly_ops ops) poly_rel"
proof -
interpret poly: idom_ops "poly_ops ops" poly_rel by (rule idom_ops_poly)
show ?thesis
by (unfold_locales, simp add: poly_rel_div poly_ops_def)
qed
lemma euclidean_ring_ops_poly: "euclidean_ring_ops (poly_ops ops) poly_rel"
proof -
interpret poly: idom_ops "poly_ops ops" poly_rel by (rule idom_ops_poly)
have id: "arith_ops_record.normalize (poly_ops ops) = normalize_poly_i ops"
"arith_ops_record.unit_factor (poly_ops ops) = unit_factor_poly_i ops"
unfolding poly_ops_def by simp_all
show ?thesis
by (unfold_locales, simp add: poly_rel_mod poly_ops_def, unfold id,
simp add: poly_rel_normalize, insert poly_rel_div poly_rel_unit_factor,
auto simp: poly_ops_def)
qed
lemma poly_rel_gcd [transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel) (gcd_poly_i ops) gcd"
proof -
interpret poly: euclidean_ring_ops "poly_ops ops" poly_rel by (rule euclidean_ring_ops_poly)
show ?thesis using poly.gcd_eucl_i unfolding gcd_poly_i_def gcd_eucl .
qed
lemma poly_rel_euclid_ext [transfer_rule]: "(poly_rel ===> poly_rel ===>
rel_prod (rel_prod poly_rel poly_rel) poly_rel) (euclid_ext_poly_i ops) euclid_ext"
proof -
interpret poly: euclidean_ring_ops "poly_ops ops" poly_rel by (rule euclidean_ring_ops_poly)
show ?thesis using poly.euclid_ext_i unfolding euclid_ext_poly_i_def .
qed
end
context ring_ops
begin
notepad
begin
fix xs x ys y
assume [transfer_rule]: "poly_rel xs x" "poly_rel ys y"
have "x * y = y * x" by simp
from this[untransferred]
have "times_poly_i ops xs ys = times_poly_i ops ys xs" .
end
end
end
Theory Poly_Mod_Finite_Field_Record_Based
subsubsection ‹Over a Finite Field›
theory Poly_Mod_Finite_Field_Record_Based
imports
Poly_Mod_Finite_Field
Finite_Field_Record_Based
Polynomial_Record_Based
begin
locale arith_ops_record = arith_ops ops + poly_mod m for ops :: "'i arith_ops_record" and m :: int
begin
definition M_rel_i :: "'i ⇒ int ⇒ bool" where
"M_rel_i f F = (arith_ops_record.to_int ops f = M F)"
definition Mp_rel_i :: "'i list ⇒ int poly ⇒ bool" where
"Mp_rel_i f F = (map (arith_ops_record.to_int ops) f = coeffs (Mp F))"
lemma Mp_rel_i_Mp[simp]: "Mp_rel_i f (Mp F) = Mp_rel_i f F" unfolding Mp_rel_i_def by auto
lemma Mp_rel_i_Mp_to_int_poly_i: "Mp_rel_i f F ⟹ Mp (to_int_poly_i ops f) = to_int_poly_i ops f"
unfolding Mp_rel_i_def to_int_poly_i_def by simp
end
locale mod_ring_gen = ring_ops ff_ops R for ff_ops :: "'i arith_ops_record" and
R :: "'i ⇒ 'a :: nontriv mod_ring ⇒ bool" +
fixes p :: int
assumes p: "p = int CARD('a)"
and of_int: "0 ≤ x ⟹ x < p ⟹ R (arith_ops_record.of_int ff_ops x) (of_int x)"
and to_int: "R y z ⟹ arith_ops_record.to_int ff_ops y = to_int_mod_ring z"
and to_int': "0 ≤ arith_ops_record.to_int ff_ops y ⟹ arith_ops_record.to_int ff_ops y < p ⟹
R y (of_int (arith_ops_record.to_int ff_ops y))"
begin
lemma nat_p: "nat p = CARD('a)" unfolding p by simp
sublocale poly_mod_type p "TYPE('a)"
by (unfold_locales, rule p)
lemma coeffs_to_int_poly: "coeffs (to_int_poly (x :: 'a mod_ring poly)) = map to_int_mod_ring (coeffs x)"
by (rule coeffs_map_poly, auto)
lemma coeffs_of_int_poly: "coeffs (of_int_poly (Mp x) :: 'a mod_ring poly) = map of_int (coeffs (Mp x))"
apply (rule coeffs_map_poly)
by (metis M_0 M_M Mp_coeff leading_coeff_0_iff of_int_hom.hom_zero to_int_mod_ring_of_int_M)
lemma to_int_poly_i: assumes "poly_rel f g" shows "to_int_poly_i ff_ops f = to_int_poly g"
proof -
have *: "map (arith_ops_record.to_int ff_ops) f = coeffs (to_int_poly g)"
unfolding coeffs_to_int_poly
by (rule nth_equalityI, insert assms, auto simp: list_all2_conv_all_nth poly_rel_def to_int)
show ?thesis unfolding coeffs_eq_iff to_int_poly_i_def poly_of_list_def coeffs_Poly *
strip_while_coeffs..
qed
lemma poly_rel_of_int_poly: assumes id: "f' = of_int_poly_i ff_ops (Mp f)" "f'' = of_int_poly (Mp f)"
shows "poly_rel f' f''" unfolding id poly_rel_def
unfolding list_all2_conv_all_nth coeffs_of_int_poly of_int_poly_i_def length_map
by (rule conjI[OF refl], intro allI impI, simp add: nth_coeffs_coeff Mp_coeff M_def, rule of_int,
insert p, auto)
sublocale arith_ops_record ff_ops p .
lemma Mp_rel_iI: "poly_rel f1 f2 ⟹ MP_Rel f3 f2 ⟹ Mp_rel_i f1 f3"
unfolding Mp_rel_i_def MP_Rel_def poly_rel_def
by (auto simp add: list_all2_conv_all_nth to_int intro: nth_equalityI)
lemma M_rel_iI: "R f1 f2 ⟹ M_Rel f3 f2 ⟹ M_rel_i f1 f3"
unfolding M_rel_i_def M_Rel_def by (simp add: to_int)
lemma M_rel_iI': assumes "R f1 f2"
shows "M_rel_i f1 (arith_ops_record.to_int ff_ops f1)"
by (rule M_rel_iI[OF assms], simp add: to_int[OF assms] M_Rel_def M_to_int_mod_ring)
lemma Mp_rel_iI': assumes "poly_rel f1 f2"
shows "Mp_rel_i f1 (to_int_poly_i ff_ops f1)"
proof (rule Mp_rel_iI[OF assms], unfold to_int_poly_i[OF assms])
show "MP_Rel (to_int_poly f2) f2" unfolding MP_Rel_def by (simp add: Mp_to_int_poly)
qed
lemma M_rel_iD: assumes "M_rel_i f1 f3"
shows
"R f1 (of_int (M f3))"
"M_Rel f3 (of_int (M f3))"
proof -
show "M_Rel f3 (of_int (M f3))"
using M_Rel_def to_int_mod_ring_of_int_M by auto
from assms show "R f1 (of_int (M f3))"
unfolding M_rel_i_def
by (metis int_one_le_iff_zero_less leD linear m1 poly_mod.M_def pos_mod_conj to_int')
qed
lemma Mp_rel_iD: assumes "Mp_rel_i f1 f3"
shows
"poly_rel f1 (of_int_poly (Mp f3))"
"MP_Rel f3 (of_int_poly (Mp f3))"
proof -
show Rel: "MP_Rel f3 (of_int_poly (Mp f3))"
using MP_Rel_def Mp_Mp Mp_f_representative by auto
let ?ti = "arith_ops_record.to_int ff_ops"
from assms[unfolded Mp_rel_i_def] have
*: "coeffs (Mp f3) = map ?ti f1" by auto
{
fix x
assume "x ∈ set f1"
hence "?ti x ∈ set (map ?ti f1)" by auto
from this[folded *] have "?ti x ∈ range M"
by (metis (no_types, lifting) MP_Rel_def M_to_int_mod_ring Rel coeffs_to_int_poly ex_map_conv range_eqI)
hence "?ti x ≥ 0" "?ti x < p" unfolding M_def using m1 by auto
hence "R x (of_int (?ti x))"
by (rule to_int')
}
thus "poly_rel f1 (of_int_poly (Mp f3))" using *
unfolding poly_rel_def coeffs_of_int_poly
by (auto simp: list_all2_map2 list_all2_same)
qed
end
locale prime_field_gen = field_ops ff_ops R + mod_ring_gen ff_ops R p for ff_ops :: "'i arith_ops_record" and
R :: "'i ⇒ 'a :: prime_card mod_ring ⇒ bool" and p :: int
begin
sublocale poly_mod_prime_type p "TYPE('a)"
by (unfold_locales, rule p)
end
lemma (in mod_ring_locale) mod_ring_rel_of_int:
"0 ≤ x ⟹ x < p ⟹ mod_ring_rel x (of_int x)"
unfolding mod_ring_rel_def
by (transfer, auto simp: p)
context prime_field
begin
lemma prime_field_finite_field_ops_int: "prime_field_gen (finite_field_ops_int p) mod_ring_rel p"
proof -
interpret field_ops "finite_field_ops_int p" mod_ring_rel by (rule finite_field_ops_int)
show ?thesis
by (unfold_locales, rule p,
auto simp: finite_field_ops_int_def p mod_ring_rel_def of_int_of_int_mod_ring)
qed
lemma prime_field_finite_field_ops_integer: "prime_field_gen (finite_field_ops_integer (integer_of_int p)) mod_ring_rel_integer p"
proof -
interpret field_ops "finite_field_ops_integer (integer_of_int p)" mod_ring_rel_integer by (rule finite_field_ops_integer, simp)
have pp: "p = int_of_integer (integer_of_int p)" by auto
interpret int: prime_field_gen "finite_field_ops_int p" mod_ring_rel
by (rule prime_field_finite_field_ops_int)
show ?thesis
by (unfold_locales, rule p, auto simp: finite_field_ops_integer_def
mod_ring_rel_integer_def[OF pp] urel_integer_def[OF pp] mod_ring_rel_of_int
int.to_int[symmetric] finite_field_ops_int_def)
qed
lemma prime_field_finite_field_ops32: assumes small: "p ≤ 65535"
shows "prime_field_gen (finite_field_ops32 (uint32_of_int p)) mod_ring_rel32 p"
proof -
let ?pp = "uint32_of_int p"
have ppp: "p = int_of_uint32 ?pp"
by (subst int_of_uint32_inv, insert small p2, auto)
note * = ppp small
interpret field_ops "finite_field_ops32 ?pp" mod_ring_rel32
by (rule finite_field_ops32, insert *)
interpret int: prime_field_gen "finite_field_ops_int p" mod_ring_rel
by (rule prime_field_finite_field_ops_int)
show ?thesis
proof (unfold_locales, rule p, auto simp: finite_field_ops32_def)
fix x
assume x: "0 ≤ x" "x < p"
from int.of_int[OF this] have "mod_ring_rel x (of_int x)" by (simp add: finite_field_ops_int_def)
thus "mod_ring_rel32 (uint32_of_int x) (of_int x)" unfolding mod_ring_rel32_def[OF *]
by (intro exI[of _ x], auto simp: urel32_def[OF *], subst int_of_uint32_inv, insert * x, auto)
next
fix y z
assume "mod_ring_rel32 y z"
from this[unfolded mod_ring_rel32_def[OF *]] obtain x where yx: "urel32 y x" and xz: "mod_ring_rel x z" by auto
from int.to_int[OF xz] have zx: "to_int_mod_ring z = x" by (simp add: finite_field_ops_int_def)
show "int_of_uint32 y = to_int_mod_ring z" unfolding zx using yx unfolding urel32_def[OF *] by simp
next
fix y
show "0 ≤ int_of_uint32 y ⟹ int_of_uint32 y < p ⟹ mod_ring_rel32 y (of_int (int_of_uint32 y))"
unfolding mod_ring_rel32_def[OF *] urel32_def[OF *]
by (intro exI[of _ "int_of_uint32 y"], auto simp: mod_ring_rel_of_int)
qed
qed
lemma prime_field_finite_field_ops64: assumes small: "p ≤ 4294967295"
shows "prime_field_gen (finite_field_ops64 (uint64_of_int p)) mod_ring_rel64 p"
proof -
let ?pp = "uint64_of_int p"
have ppp: "p = int_of_uint64 ?pp"
by (subst int_of_uint64_inv, insert small p2, auto)
note * = ppp small
interpret field_ops "finite_field_ops64 ?pp" mod_ring_rel64
by (rule finite_field_ops64, insert *)
interpret int: prime_field_gen "finite_field_ops_int p" mod_ring_rel
by (rule prime_field_finite_field_ops_int)
show ?thesis
proof (unfold_locales, rule p, auto simp: finite_field_ops64_def)
fix x
assume x: "0 ≤ x" "x < p"
from int.of_int[OF this] have "mod_ring_rel x (of_int x)" by (simp add: finite_field_ops_int_def)
thus "mod_ring_rel64 (uint64_of_int x) (of_int x)" unfolding mod_ring_rel64_def[OF *]
by (intro exI[of _ x], auto simp: urel64_def[OF *], subst int_of_uint64_inv, insert * x, auto)
next
fix y z
assume "mod_ring_rel64 y z"
from this[unfolded mod_ring_rel64_def[OF *]] obtain x where yx: "urel64 y x" and xz: "mod_ring_rel x z" by auto
from int.to_int[OF xz] have zx: "to_int_mod_ring z = x" by (simp add: finite_field_ops_int_def)
show "int_of_uint64 y = to_int_mod_ring z" unfolding zx using yx unfolding urel64_def[OF *] by simp
next
fix y
show "0 ≤ int_of_uint64 y ⟹ int_of_uint64 y < p ⟹ mod_ring_rel64 y (of_int (int_of_uint64 y))"
unfolding mod_ring_rel64_def[OF *] urel64_def[OF *]
by (intro exI[of _ "int_of_uint64 y"], auto simp: mod_ring_rel_of_int)
qed
qed
end
context mod_ring_locale
begin
lemma mod_ring_finite_field_ops_int: "mod_ring_gen (finite_field_ops_int p) mod_ring_rel p"
proof -
interpret ring_ops "finite_field_ops_int p" mod_ring_rel by (rule ring_finite_field_ops_int)
show ?thesis
by (unfold_locales, rule p,
auto simp: finite_field_ops_int_def p mod_ring_rel_def of_int_of_int_mod_ring)
qed
lemma mod_ring_finite_field_ops_integer: "mod_ring_gen (finite_field_ops_integer (integer_of_int p)) mod_ring_rel_integer p"
proof -
interpret ring_ops "finite_field_ops_integer (integer_of_int p)" mod_ring_rel_integer by (rule ring_finite_field_ops_integer, simp)
have pp: "p = int_of_integer (integer_of_int p)" by auto
interpret int: mod_ring_gen "finite_field_ops_int p" mod_ring_rel
by (rule mod_ring_finite_field_ops_int)
show ?thesis
by (unfold_locales, rule p, auto simp: finite_field_ops_integer_def
mod_ring_rel_integer_def[OF pp] urel_integer_def[OF pp] mod_ring_rel_of_int
int.to_int[symmetric] finite_field_ops_int_def)
qed
lemma mod_ring_finite_field_ops32: assumes small: "p ≤ 65535"
shows "mod_ring_gen (finite_field_ops32 (uint32_of_int p)) mod_ring_rel32 p"
proof -
let ?pp = "uint32_of_int p"
have ppp: "p = int_of_uint32 ?pp"
by (subst int_of_uint32_inv, insert small p2, auto)
note * = ppp small
interpret ring_ops "finite_field_ops32 ?pp" mod_ring_rel32
by (rule ring_finite_field_ops32, insert *)
interpret int: mod_ring_gen "finite_field_ops_int p" mod_ring_rel
by (rule mod_ring_finite_field_ops_int)
show ?thesis
proof (unfold_locales, rule p, auto simp: finite_field_ops32_def)
fix x
assume x: "0 ≤ x" "x < p"
from int.of_int[OF this] have "mod_ring_rel x (of_int x)" by (simp add: finite_field_ops_int_def)
thus "mod_ring_rel32 (uint32_of_int x) (of_int x)" unfolding mod_ring_rel32_def[OF *]
by (intro exI[of _ x], auto simp: urel32_def[OF *], subst int_of_uint32_inv, insert * x, auto)
next
fix y z
assume "mod_ring_rel32 y z"
from this[unfolded mod_ring_rel32_def[OF *]] obtain x where yx: "urel32 y x" and xz: "mod_ring_rel x z" by auto
from int.to_int[OF xz] have zx: "to_int_mod_ring z = x" by (simp add: finite_field_ops_int_def)
show "int_of_uint32 y = to_int_mod_ring z" unfolding zx using yx unfolding urel32_def[OF *] by simp
next
fix y
show "0 ≤ int_of_uint32 y ⟹ int_of_uint32 y < p ⟹ mod_ring_rel32 y (of_int (int_of_uint32 y))"
unfolding mod_ring_rel32_def[OF *] urel32_def[OF *]
by (intro exI[of _ "int_of_uint32 y"], auto simp: mod_ring_rel_of_int)
qed
qed
lemma mod_ring_finite_field_ops64: assumes small: "p ≤ 4294967295"
shows "mod_ring_gen (finite_field_ops64 (uint64_of_int p)) mod_ring_rel64 p"
proof -
let ?pp = "uint64_of_int p"
have ppp: "p = int_of_uint64 ?pp"
by (subst int_of_uint64_inv, insert small p2, auto)
note * = ppp small
interpret ring_ops "finite_field_ops64 ?pp" mod_ring_rel64
by (rule ring_finite_field_ops64, insert *)
interpret int: mod_ring_gen "finite_field_ops_int p" mod_ring_rel
by (rule mod_ring_finite_field_ops_int)
show ?thesis
proof (unfold_locales, rule p, auto simp: finite_field_ops64_def)
fix x
assume x: "0 ≤ x" "x < p"
from int.of_int[OF this] have "mod_ring_rel x (of_int x)" by (simp add: finite_field_ops_int_def)
thus "mod_ring_rel64 (uint64_of_int x) (of_int x)" unfolding mod_ring_rel64_def[OF *]
by (intro exI[of _ x], auto simp: urel64_def[OF *], subst int_of_uint64_inv, insert * x, auto)
next
fix y z
assume "mod_ring_rel64 y z"
from this[unfolded mod_ring_rel64_def[OF *]] obtain x where yx: "urel64 y x" and xz: "mod_ring_rel x z" by auto
from int.to_int[OF xz] have zx: "to_int_mod_ring z = x" by (simp add: finite_field_ops_int_def)
show "int_of_uint64 y = to_int_mod_ring z" unfolding zx using yx unfolding urel64_def[OF *] by simp
next
fix y
show "0 ≤ int_of_uint64 y ⟹ int_of_uint64 y < p ⟹ mod_ring_rel64 y (of_int (int_of_uint64 y))"
unfolding mod_ring_rel64_def[OF *] urel64_def[OF *]
by (intro exI[of _ "int_of_uint64 y"], auto simp: mod_ring_rel_of_int)
qed
qed
end
end
Theory Chinese_Remainder_Poly
subsection ‹Chinese Remainder Theorem for Polynomials›
text ‹We prove the Chinese Remainder Theorem, and strengthen it by showing uniqueness›
theory Chinese_Remainder_Poly
imports
"HOL-Number_Theory.Residues"
Polynomial_Factorization.Polynomial_Divisibility
Polynomial_Interpolation.Missing_Polynomial
begin
lemma cong_add_poly:
"[(a::'b::{field_gcd} poly) = b] (mod m) ⟹ [c = d] (mod m) ⟹ [a + c = b + d] (mod m)"
by (fact cong_add)
lemma cong_mult_poly:
"[(a::'b::{field_gcd} poly) = b] (mod m) ⟹ [c = d] (mod m) ⟹ [a * c = b * d] (mod m)"
by (fact cong_mult)
lemma cong_mult_self_poly: "[(a::'b::{field_gcd} poly) * m = 0] (mod m)"
by (fact cong_mult_self_right)
lemma cong_scalar2_poly: "[(a::'b::{field_gcd} poly)= b] (mod m) ⟹ [k * a = k * b] (mod m)"
by (fact cong_scalar_left)
lemma cong_sum_poly:
"(⋀x. x ∈ A ⟹ [((f x)::'b::{field_gcd} poly) = g x] (mod m)) ⟹
[(∑x∈A. f x) = (∑x∈A. g x)] (mod m)"
by (rule cong_sum)
lemma cong_iff_lin_poly: "([(a::'b::{field_gcd} poly) = b] (mod m)) = (∃k. b = a + m * k)"
using cong_diff_iff_cong_0 [of b a m] by (auto simp add: cong_0_iff dvd_def algebra_simps dest: cong_sym)
lemma cong_solve_poly: "(a::'b::{field_gcd} poly) ≠ 0 ⟹ ∃x. [a * x = gcd a n] (mod n)"
proof (cases "n = 0")
case True
note n0=True
show ?thesis
proof (cases "monic a")
case True
have n: "normalize a = a" by (rule normalize_monic[OF True])
show ?thesis
by (rule exI[of _ 1], auto simp add: n0 n cong_def)
next
case False
show ?thesis
by (auto simp add: True cong_def normalize_poly_old_def map_div_is_smult_inverse)
(metis mult.right_neutral mult_smult_right)
qed
next
case False
note n_not_0 = False
show ?thesis
using bezout_coefficients_fst_snd [of a n, symmetric]
by (auto simp add: cong_iff_lin_poly mult.commute [of a] mult.commute [of n])
qed
lemma cong_solve_coprime_poly:
assumes coprime_an:"coprime (a::'b::{field_gcd} poly) n"
shows "∃x. [a * x = 1] (mod n)"
proof (cases "a = 0")
case True
show ?thesis unfolding cong_def
using True coprime_an by auto
next
case False
show ?thesis
using coprime_an cong_solve_poly[OF False, of n]
unfolding cong_def
by presburger
qed
lemma cong_dvd_modulus_poly:
"[x = y] (mod m) ⟹ n dvd m ⟹ [x = y] (mod n)" for x y :: "'b::{field_gcd} poly"
by (auto simp add: cong_iff_lin_poly elim!: dvdE)
lemma chinese_remainder_aux_poly:
fixes A :: "'a set"
and m :: "'a ⇒ 'b::{field_gcd} poly"
assumes fin: "finite A"
and cop: "∀i ∈ A. (∀j ∈ A. i ≠ j ⟶ coprime (m i) (m j))"
shows "∃b. (∀i ∈ A. [b i = 1] (mod m i) ∧ [b i = 0] (mod (∏j ∈ A - {i}. m j)))"
proof (rule finite_set_choice, rule fin, rule ballI)
fix i
assume "i : A"
with cop have "coprime (∏j ∈ A - {i}. m j) (m i)"
by (auto intro: prod_coprime_left)
then have "∃x. [(∏j ∈ A - {i}. m j) * x = 1] (mod m i)"
by (elim cong_solve_coprime_poly)
then obtain x where "[(∏j ∈ A - {i}. m j) * x = 1] (mod m i)"
by auto
moreover have "[(∏j ∈ A - {i}. m j) * x = 0]
(mod (∏j ∈ A - {i}. m j))"
by (subst mult.commute, rule cong_mult_self_poly)
ultimately show "∃a. [a = 1] (mod m i) ∧ [a = 0]
(mod prod m (A - {i}))"
by blast
qed
lemma chinese_remainder_poly:
fixes A :: "'a set"
and m :: "'a ⇒ 'b::{field_gcd} poly"
and u :: "'a ⇒ 'b poly"
assumes fin: "finite A"
and cop: "∀i∈A. (∀j∈A. i ≠ j ⟶ coprime (m i) (m j))"
shows "∃x. (∀i∈A. [x = u i] (mod m i))"
proof -
from chinese_remainder_aux_poly [OF fin cop] obtain b where
bprop: "∀i∈A. [b i = 1] (mod m i) ∧
[b i = 0] (mod (∏j ∈ A - {i}. m j))"
by blast
let ?x = "∑i∈A. (u i) * (b i)"
show "?thesis"
proof (rule exI, clarify)
fix i
assume a: "i : A"
show "[?x = u i] (mod m i)"
proof -
from fin a have "?x = (∑j ∈ {i}. u j * b j) +
(∑j ∈ A - {i}. u j * b j)"
by (subst sum.union_disjoint [symmetric], auto intro: sum.cong)
then have "[?x = u i * b i + (∑j ∈ A - {i}. u j * b j)] (mod m i)"
unfolding cong_def
by auto
also have "[u i * b i + (∑j ∈ A - {i}. u j * b j) =
u i * 1 + (∑j ∈ A - {i}. u j * 0)] (mod m i)"
apply (rule cong_add_poly)
apply (rule cong_scalar2_poly)
using bprop a apply blast
apply (rule cong_sum)
apply (rule cong_scalar2_poly)
using bprop apply auto
apply (rule cong_dvd_modulus_poly)
apply (drule (1) bspec)
apply (erule conjE)
apply assumption
apply rule
using fin a apply auto
done
thus ?thesis
by (metis (no_types, lifting) a add.right_neutral fin mult_cancel_left1 mult_cancel_right1
sum.not_neutral_contains_not_neutral sum.remove)
qed
qed
qed
lemma cong_trans_poly:
"[(a::'b::{field_gcd} poly) = b] (mod m) ⟹ [b = c] (mod m) ⟹ [a = c] (mod m)"
by (fact cong_trans)
lemma cong_mod_poly: "(n::'b::{field_gcd} poly) ~= 0 ⟹ [a mod n = a] (mod n)"
by auto
lemma cong_sym_poly: "[(a::'b::{field_gcd} poly) = b] (mod m) ⟹ [b = a] (mod m)"
by (fact cong_sym)
lemma cong_1_poly: "[(a::'b::{field_gcd} poly) = b] (mod 1)"
by (fact cong_1)
lemma coprime_cong_mult_poly:
assumes "[(a::'b::{field_gcd} poly) = b] (mod m)" and "[a = b] (mod n)" and "coprime m n"
shows "[a = b] (mod m * n)"
using divides_mult assms
by (metis (no_types, hide_lams) cong_dvd_modulus_poly cong_iff_lin_poly dvd_mult2 dvd_refl minus_add_cancel mult.right_neutral)
lemma coprime_cong_prod_poly:
"(∀i∈A. (∀j∈A. i ≠ j ⟶ coprime (m i) (m j))) ⟹
(∀i∈A. [(x::'b::{field_gcd} poly) = y] (mod m i)) ⟹
[x = y] (mod (∏i∈A. m i))"
apply (induct A rule: infinite_finite_induct)
apply auto
apply (metis coprime_cong_mult_poly prod_coprime_right)
done
lemma cong_less_modulus_unique_poly:
"[(x::'b::{field_gcd} poly) = y] (mod m) ⟹ degree x < degree m ⟹ degree y < degree m ⟹ x = y"
by (simp add: cong_def mod_poly_less)
lemma chinese_remainder_unique_poly:
fixes A :: "'a set"
and m :: "'a ⇒ 'b::{field_gcd} poly"
and u :: "'a ⇒ 'b poly"
assumes nz: "∀i∈A. (m i) ≠ 0"
and cop: "∀i∈A. (∀j∈A. i ≠ j ⟶ coprime (m i) (m j))"
and not_constant: "0 < degree (prod m A)"
shows "∃!x. degree x < (∑i∈A. degree (m i)) ∧ (∀i∈A. [x = u i] (mod m i))"
proof -
from not_constant have fin: "finite A"
by (metis degree_1 gr_implies_not0 prod.infinite)
from chinese_remainder_poly [OF fin cop]
obtain y where one: "(∀i∈A. [y = u i] (mod m i))"
by blast
let ?x = "y mod (∏i∈A. m i)"
have degree_prod_sum: "degree (prod m A) = (∑i∈A. degree (m i))"
by (rule degree_prod_eq_sum_degree[OF nz])
from fin nz have prodnz: "(∏i∈A. (m i)) ≠ 0"
by auto
have less: "degree ?x < (∑i∈A. degree (m i))"
unfolding degree_prod_sum[symmetric]
using degree_mod_less[OF prodnz, of y]
using not_constant
by auto
have cong: "∀i∈A. [?x = u i] (mod m i)"
apply auto
apply (rule cong_trans_poly)
prefer 2
using one apply auto
apply (rule cong_dvd_modulus_poly)
apply (rule cong_mod_poly)
using prodnz apply auto
apply rule
apply (rule fin)
apply assumption
done
have unique: "∀z. degree z < (∑i∈A. degree (m i)) ∧
(∀i∈A. [z = u i] (mod m i)) ⟶ z = ?x"
proof (clarify)
fix z::"'b poly"
assume zless: "degree z < (∑i∈A. degree (m i))"
assume zcong: "(∀i∈A. [z = u i] (mod m i))"
have deg1: "degree z < degree (prod m A)"
using degree_prod_sum zless by simp
have deg2: "degree ?x < degree (prod m A)"
by (metis deg1 degree_0 degree_mod_less gr0I gr_implies_not0)
have "∀i∈A. [?x = z] (mod m i)"
apply clarify
apply (rule cong_trans_poly)
using cong apply (erule bspec)
apply (rule cong_sym_poly)
using zcong by auto
with fin cop have "[?x = z] (mod (∏i∈A. m i))"
by (intro coprime_cong_prod_poly) auto
with zless show "z = ?x"
apply (intro cong_less_modulus_unique_poly)
apply (erule cong_sym_poly)
apply (auto simp add: deg1 deg2)
done
qed
from less cong unique show ?thesis by blast
qed
end
Theory Berlekamp_Type_Based
section ‹The Berlekamp Algorithm›
theory Berlekamp_Type_Based
imports
Jordan_Normal_Form.Matrix_Kernel
Jordan_Normal_Form.Gauss_Jordan_Elimination
Jordan_Normal_Form.Missing_VectorSpace
Polynomial_Factorization.Square_Free_Factorization
Polynomial_Factorization.Missing_Multiset
Finite_Field
Chinese_Remainder_Poly
Poly_Mod_Finite_Field
"HOL-Computational_Algebra.Field_as_Ring"
begin
hide_const (open) up_ring.coeff up_ring.monom Modules.module subspace
Modules.module_hom
subsection ‹Auxiliary lemmas›
context
fixes g :: "'b ⇒ 'a :: comm_monoid_mult"
begin
lemma prod_list_map_filter: "prod_list (map g (filter f xs)) * prod_list (map g (filter (λ x. ¬ f x) xs))
= prod_list (map g xs)"
by (induct xs, auto simp: ac_simps)
lemma prod_list_map_partition:
assumes "List.partition f xs = (ys, zs)"
shows "prod_list (map g xs) = prod_list (map g ys) * prod_list (map g zs)"
using assms by (subst prod_list_map_filter[symmetric, of _ f], auto simp: o_def)
end
lemma coprime_id_is_unit:
fixes a::"'b::semiring_gcd"
shows "coprime a a ⟷ is_unit a"
using dvd_unit_imp_unit by auto
lemma dim_vec_of_list[simp]: "dim_vec (vec_of_list x) = length x"
by (transfer, auto)
lemma length_list_of_vec[simp]: "length (list_of_vec A) = dim_vec A"
by (transfer', auto)
lemma list_of_vec_vec_of_list[simp]: "list_of_vec (vec_of_list a) = a"
proof -
{
fix aa :: "'a list"
have "map (λn. if n < length aa then aa ! n else undef_vec (n - length aa)) [0..<length aa]
= map ((!) aa) [0..<length aa]"
by simp
hence "map (λn. if n < length aa then aa ! n else undef_vec (n - length aa)) [0..<length aa] = aa"
by (simp add: map_nth)
}
thus ?thesis by (transfer, simp add: mk_vec_def)
qed
context
assumes "SORT_CONSTRAINT('a::finite)"
begin
lemma inj_Poly_list_of_vec': "inj_on (Poly ∘ list_of_vec) {v. dim_vec v = n}"
proof (rule comp_inj_on)
show "inj_on list_of_vec {v. dim_vec v = n}"
by (auto simp add: inj_on_def, transfer, auto simp add: mk_vec_def)
show "inj_on Poly (list_of_vec ` {v. dim_vec v = n})"
proof (auto simp add: inj_on_def)
fix x y::"'c vec" assume "n = dim_vec x" and dim_xy: "dim_vec y = dim_vec x"
and Poly_eq: "Poly (list_of_vec x) = Poly (list_of_vec y)"
note [simp del] = nth_list_of_vec
show "list_of_vec x = list_of_vec y"
proof (rule nth_equalityI, auto simp: dim_xy)
have length_eq: "length (list_of_vec x ) = length (list_of_vec y)"
using dim_xy by (transfer, auto)
fix i assume "i < dim_vec x"
thus "list_of_vec x ! i = list_of_vec y ! i" using Poly_eq unfolding poly_eq_iff coeff_Poly_eq
using dim_xy unfolding nth_default_def by (auto, presburger)
qed
qed
qed
corollary inj_Poly_list_of_vec: "inj_on (Poly ∘ list_of_vec) (carrier_vec n)"
using inj_Poly_list_of_vec' unfolding carrier_vec_def .
lemma list_of_vec_rw_map: "list_of_vec m = map (λn. m $ n) [0..<dim_vec m]"
by (transfer, auto simp add: mk_vec_def)
lemma degree_Poly':
assumes xs: "xs ≠ []"
shows "degree (Poly xs) < length xs"
using xs
by (induct xs, auto intro: Poly.simps(1))
lemma vec_of_list_list_of_vec[simp]: "vec_of_list (list_of_vec a) = a"
by (transfer, auto simp add: mk_vec_def)
lemma row_mat_of_rows_list:
assumes b: "b < length A"
and nc: "∀i. i < length A ⟶ length (A ! i) = nc"
shows "(row (mat_of_rows_list nc A) b) = vec_of_list (A ! b)"
proof (auto simp add: vec_eq_iff)
show "dim_col (mat_of_rows_list nc A) = length (A ! b)"
unfolding mat_of_rows_list_def using b nc by auto
fix i assume i: "i < length (A ! b)"
show "row (mat_of_rows_list nc A) b $ i = vec_of_list (A ! b) $ i"
using i b nc
unfolding mat_of_rows_list_def row_def
by (transfer, auto simp add: mk_vec_def mk_mat_def)
qed
lemma degree_Poly_list_of_vec:
assumes n: "x ∈ carrier_vec n"
and n0: "n > 0"
shows "degree (Poly (list_of_vec x)) < n"
proof -
have x_dim: "dim_vec x = n" using n by auto
have l: "(list_of_vec x) ≠ []"
by (auto simp add: list_of_vec_rw_map vec_of_dim_0[symmetric] n0 n x_dim)
have "degree (Poly (list_of_vec x)) < length (list_of_vec x)" by (rule degree_Poly'[OF l])
also have "... = n" using x_dim by auto
finally show ?thesis .
qed
lemma list_of_vec_nth:
assumes i: "i < dim_vec x"
shows "list_of_vec x ! i = x $ i"
using i
by (transfer, auto simp add: mk_vec_def)
lemma coeff_Poly_list_of_vec_nth':
assumes i: "i < dim_vec x"
shows "coeff (Poly (list_of_vec x)) i = x $ i"
using i
by (auto simp add: list_of_vec_nth nth_default_def)
lemma list_of_vec_row_nth:
assumes x: "x < dim_col A"
shows "list_of_vec (row A i) ! x = A $$ (i, x)"
using x unfolding row_def by (transfer', auto simp add: mk_vec_def)
lemma coeff_Poly_list_of_vec_nth:
assumes x: "x < dim_col A"
shows "coeff (Poly (list_of_vec (row A i))) x = A $$ (i, x)"
proof -
have "coeff (Poly (list_of_vec (row A i))) x = nth_default 0 (list_of_vec (row A i)) x"
unfolding coeff_Poly_eq by simp
also have "... = A $$ (i, x)" using x list_of_vec_row_nth
unfolding nth_default_def by (auto simp del: nth_list_of_vec)
finally show ?thesis .
qed
lemma inj_on_list_of_vec: "inj_on list_of_vec (carrier_vec n)"
unfolding inj_on_def unfolding list_of_vec_rw_map by auto
lemma vec_of_list_carrier[simp]: "vec_of_list x ∈ carrier_vec (length x)"
unfolding carrier_vec_def by simp
lemma card_carrier_vec: "card (carrier_vec n:: 'b::finite vec set) = CARD('b) ^ n"
proof -
let ?A = "UNIV::'b set"
let ?B = "{xs. set xs ⊆ ?A ∧ length xs = n}"
let ?C = "(carrier_vec n:: 'b::finite vec set)"
have "card ?C = card ?B"
proof -
have "bij_betw (list_of_vec) ?C ?B"
proof (unfold bij_betw_def, auto)
show "inj_on list_of_vec (carrier_vec n)" by (rule inj_on_list_of_vec)
fix x::"'b list"
assume n: "n = length x"
thus "x ∈ list_of_vec ` carrier_vec (length x)"
unfolding image_def
by auto (rule bexI[of _ "vec_of_list x"], auto)
qed
thus ?thesis using bij_betw_same_card by blast
qed
also have "... = card ?A ^ n"
by (rule card_lists_length_eq, simp)
finally show ?thesis .
qed
lemma finite_carrier_vec[simp]: "finite (carrier_vec n:: 'b::finite vec set)"
by (rule card_ge_0_finite, unfold card_carrier_vec, auto)
lemma row_echelon_form_dim0_row:
assumes "A ∈ carrier_mat 0 n"
shows "row_echelon_form A"
using assms
unfolding row_echelon_form_def pivot_fun_def Let_def by auto
lemma row_echelon_form_dim0_col:
assumes "A ∈ carrier_mat n 0"
shows "row_echelon_form A"
using assms
unfolding row_echelon_form_def pivot_fun_def Let_def by auto
lemma row_echelon_form_one_dim0[simp]: "row_echelon_form (1⇩m 0)"
unfolding row_echelon_form_def pivot_fun_def Let_def by auto
lemma Poly_list_of_vec_0[simp]: "Poly (list_of_vec (0⇩v 0)) = [:0:]"
by (simp add: poly_eq_iff nth_default_def)
lemma monic_normalize:
assumes "(p :: 'b :: {field,euclidean_ring_gcd} poly) ≠ 0" shows "monic (normalize p)"
by (simp add: assms normalize_poly_old_def)
lemma exists_factorization_prod_list:
fixes P::"'b::field poly list"
assumes "degree (prod_list P) > 0"
and "⋀ u. u ∈ set P ⟹ degree u > 0 ∧ monic u"
and "square_free (prod_list P)"
shows "∃Q. prod_list Q = prod_list P ∧ length P ≤ length Q
∧ (∀u. u ∈ set Q ⟶ irreducible u ∧ monic u)"
using assms
proof (induct P)
case Nil
thus ?case by auto
next
case (Cons x P)
have sf_P: "square_free (prod_list P)"
by (metis Cons.prems(3) dvd_triv_left prod_list.Cons mult.commute square_free_factor)
have deg_x: "degree x > 0" using Cons.prems by auto
have distinct_P: "distinct P"
by (meson Cons.prems(2) Cons.prems(3) distinct.simps(2) square_free_prod_list_distinct)
have "∃A. finite A ∧ x = ∏A ∧ A ⊆ {q. irreducible q ∧ monic q}"
proof (rule monic_square_free_irreducible_factorization)
show "monic x" by (simp add: Cons.prems(2))
show "square_free x"
by (metis Cons.prems(3) dvd_triv_left prod_list.Cons square_free_factor)
qed
from this obtain A where fin_A: "finite A"
and xA: "x = ∏A"
and A: "A ⊆ {q. irreducible⇩d q ∧ monic q}"
by auto
obtain A' where s: "set A' = A" and length_A': "length A' = card A"
using ‹finite A› distinct_card finite_distinct_list by force
have A_not_empty: "A ≠ {}" using xA deg_x by auto
have x_prod_list_A': "x = prod_list A'"
proof -
have "x = ∏A" using xA by simp
also have "... = prod id A" by simp
also have "... = prod id (set A')" unfolding s by simp
also have "... = prod_list (map id A')"
by (rule prod.distinct_set_conv_list, simp add: card_distinct length_A' s)
also have "... = prod_list A'" by auto
finally show ?thesis .
qed
show ?case
proof (cases "P = []")
case True
show ?thesis
proof (rule exI[of _ "A'"], auto simp add: True)
show "prod_list A' = x" using x_prod_list_A' by simp
show "Suc 0 ≤ length A'" using A_not_empty using s length_A'
by (simp add: Suc_leI card_gt_0_iff fin_A)
show "⋀u. u ∈ set A' ⟹ irreducible u" using s A by auto
show "⋀u. u ∈ set A' ⟹ monic u" using s A by auto
qed
next
case False
have hyp: "∃Q. prod_list Q = prod_list P
∧ length P ≤ length Q ∧ (∀u. u ∈ set Q ⟶ irreducible u ∧ monic u)"
proof (rule Cons.hyps[OF _ _ sf_P])
have set_P: "set P ≠ {}" using False by auto
have "prod_list P = prod_list (map id P)" by simp
also have "... = prod id (set P)"
using prod.distinct_set_conv_list[OF distinct_P, of id] by simp
also have "... = ∏(set P)" by simp
finally have "prod_list P = ∏(set P)" .
hence "degree (prod_list P) = degree (∏(set P))" by simp
also have "... = degree (prod id (set P))" by simp
also have "... = (∑i∈(set P). degree (id i))"
proof (rule degree_prod_eq_sum_degree)
show "∀i∈set P. id i ≠ 0" using Cons.prems(2) by force
qed
also have "... > 0"
by (metis Cons.prems(2) List.finite_set set_P gr0I id_apply insert_iff list.set(2) sum_pos)
finally show "degree (prod_list P) > 0" by simp
show "⋀u. u ∈ set P ⟹ degree u > 0 ∧ monic u" using Cons.prems by auto
qed
from this obtain Q where QP: "prod_list Q = prod_list P" and length_PQ: "length P ≤ length Q"
and monic_irr_Q: "(∀u. u ∈ set Q ⟶ irreducible u ∧ monic u)" by blast
show ?thesis
proof (rule exI[of _ "A' @ Q"], auto simp add: monic_irr_Q)
show "prod_list A' * prod_list Q = x * prod_list P" unfolding QP x_prod_list_A' by auto
have "length A' ≠ 0" using A_not_empty using s length_A' by auto
thus "Suc (length P) ≤ length A' + length Q" using QP length_PQ by linarith
show "⋀u. u ∈ set A' ⟹ irreducible u" using s A by auto
show "⋀u. u ∈ set A' ⟹ monic u" using s A by auto
qed
qed
qed
lemma normalize_eq_imp_smult:
fixes p :: "'b :: {euclidean_ring_gcd} poly"
assumes n: "normalize p = normalize q"
shows "∃ c. c ≠ 0 ∧ q = smult c p"
proof(cases "p = 0")
case True with n show ?thesis by (auto intro:exI[of _ 1])
next
case p0: False
have degree_eq: "degree p = degree q" using n degree_normalize by metis
hence q0: "q ≠ 0" using p0 n by auto
have p_dvd_q: "p dvd q" using n by (simp add: associatedD1)
from p_dvd_q obtain k where q: "q = k * p" unfolding dvd_def by (auto simp: ac_simps)
with q0 have "k ≠ 0" by auto
then have "degree k = 0"
using degree_eq degree_mult_eq p0 q by fastforce
then obtain c where k: "k = [: c :]" by (metis degree_0_id)
with ‹k ≠ 0› have "c ≠ 0" by auto
have "q = smult c p" unfolding q k by simp
with ‹c ≠ 0› show ?thesis by auto
qed
lemma prod_list_normalize:
fixes P :: "'b :: {idom_divide,normalization_semidom_multiplicative} poly list"
shows "normalize (prod_list P) = prod_list (map normalize P)"
proof (induct P)
case Nil
show ?case by auto
next
case (Cons p P)
have "normalize (prod_list (p # P)) = normalize p * normalize (prod_list P)"
using normalize_mult by auto
also have "... = normalize p * prod_list (map normalize P)" using Cons.hyps by auto
also have "... = prod_list (normalize p # (map normalize P))" by auto
also have "... = prod_list (map normalize (p # P))" by auto
finally show ?case .
qed
lemma prod_list_dvd_prod_list_subset:
fixes A::"'b::comm_monoid_mult list"
assumes dA: "distinct A"
and dB: "distinct B"
and s: "set A ⊆ set B"
shows "prod_list A dvd prod_list B"
proof -
have "prod_list A = prod_list (map id A)" by auto
also have "... = prod id (set A)"
by (rule prod.distinct_set_conv_list[symmetric, OF dA])
also have "... dvd prod id (set B)"
by (rule prod_dvd_prod_subset[OF _ s], auto)
also have "... = prod_list (map id B)"
by (rule prod.distinct_set_conv_list[OF dB])
also have "... = prod_list B" by simp
finally show ?thesis .
qed
end
lemma gcd_monic_constant:
"gcd f g ∈ {1, f}" if "monic f" and "degree g = 0"
for f g :: "'a :: {field_gcd} poly"
proof (cases "g = 0")
case True
moreover from ‹monic f› have "normalize f = f"
by (rule normalize_monic)
ultimately show ?thesis
by simp
next
case False
with ‹degree g = 0› have "is_unit g"
by simp
then have "Rings.coprime f g"
by (rule is_unit_right_imp_coprime)
then show ?thesis
by simp
qed
lemma distinct_find_base_vectors:
fixes A::"'a::field mat"
assumes ref: "row_echelon_form A"
and A: "A ∈ carrier_mat nr nc"
shows "distinct (find_base_vectors A)"
proof -
note non_pivot_base = non_pivot_base[OF ref A]
let ?pp = "set (pivot_positions A)"
from A have dim: "dim_row A = nr" "dim_col A = nc" by auto
{
fix j j'
assume j: "j < nc" "j ∉ snd ` ?pp" and j': "j' < nc" "j' ∉ snd ` ?pp" and neq: "j' ≠ j"
from non_pivot_base(2)[OF j] non_pivot_base(4)[OF j' j neq]
have "non_pivot_base A (pivot_positions A) j ≠ non_pivot_base A (pivot_positions A) j'" by auto
}
hence inj: "inj_on (non_pivot_base A (pivot_positions A))
(set [j←[0..<nc] . j ∉ snd ` ?pp])" unfolding inj_on_def by auto
thus ?thesis unfolding find_base_vectors_def Let_def unfolding distinct_map dim by auto
qed
lemma length_find_base_vectors:
fixes A::"'a::field mat"
assumes ref: "row_echelon_form A"
and A: "A ∈ carrier_mat nr nc"
shows "length (find_base_vectors A) = card (set (find_base_vectors A))"
using distinct_card[OF distinct_find_base_vectors[OF ref A]] by auto
subsection ‹Previous Results›
definition power_poly_f_mod :: "'a::field poly ⇒ 'a poly ⇒ nat ⇒ 'a poly" where
"power_poly_f_mod modulus = (λa n. a ^ n mod modulus)"
lemma power_poly_f_mod_binary: "power_poly_f_mod m a n = (if n = 0 then 1 mod m
else let (d, r) = Divides.divmod_nat n 2;
rec = power_poly_f_mod m ((a * a) mod m) d in
if r = 0 then rec else (rec * a) mod m)"
for m a :: "'a :: {field_gcd} poly"
proof -
note d = power_poly_f_mod_def
show ?thesis
proof (cases "n = 0")
case True
thus ?thesis unfolding d by simp
next
case False
obtain q r where div: "Divides.divmod_nat n 2 = (q,r)" by force
hence n: "n = 2 * q + r" and r: "r = 0 ∨ r = 1" unfolding divmod_nat_def by auto
have id: "a ^ (2 * q) = (a * a) ^ q"
by (simp add: power_mult_distrib semiring_normalization_rules)
show ?thesis
proof (cases "r = 0")
case True
show ?thesis
using power_mod [of "a * a" m q]
by (auto simp add: divmod_nat_def Let_def True n d div id)
next
case False
with r have r: "r = 1" by simp
show ?thesis
by (auto simp add: d r div Let_def mod_simps)
(simp add: n r mod_simps ac_simps power_mult_distrib power_mult power2_eq_square)
qed
qed
qed
fun power_polys where
"power_polys mul_p u curr_p (Suc i) = curr_p #
power_polys mul_p u ((curr_p * mul_p) mod u) i"
| "power_polys mul_p u curr_p 0 = []"
context
assumes "SORT_CONSTRAINT('a::prime_card)"
begin
lemma fermat_theorem_mod_ring [simp]:
fixes a::"'a mod_ring"
shows "a ^ CARD('a) = a"
proof (cases "a = 0")
case True
then show ?thesis by auto
next
case False
then show ?thesis
proof transfer
fix a
assume "a ∈ {0..<int CARD('a)}" and "a ≠ 0"
then have a: "1 ≤ a" "a < int CARD('a)"
by simp_all
then have [simp]: "a mod int CARD('a) = a"
by simp
from a have "¬ int CARD('a) dvd a"
by (auto simp add: zdvd_not_zless)
then have "¬ CARD('a) dvd nat ¦a¦"
by simp
with a have "¬ CARD('a) dvd nat a"
by simp
with prime_card have "[nat a ^ (CARD('a) - 1) = 1] (mod CARD('a))"
by (rule fermat_theorem)
with a have "int (nat a ^ (CARD('a) - 1) mod CARD('a)) = 1"
by (simp add: cong_def)
with a have "a ^ (CARD('a) - 1) mod CARD('a) = 1"
by (simp add: of_nat_mod)
then have "a * (a ^ (CARD('a) - 1) mod int CARD('a)) = a"
by simp
then have "(a * (a ^ (CARD('a) - 1) mod int CARD('a))) mod int CARD('a) = a mod int CARD('a)"
by (simp only:)
then show "a ^ CARD('a) mod int CARD('a) = a"
by (simp add: mod_simps semiring_normalization_rules(27))
qed
qed
lemma mod_eq_dvd_iff_poly: "((x::'a mod_ring poly) mod n = y mod n) = (n dvd x - y)"
proof
assume H: "x mod n = y mod n"
hence "x mod n - y mod n = 0" by simp
hence "(x mod n - y mod n) mod n = 0" by simp
hence "(x - y) mod n = 0" by (simp add: mod_diff_eq)
thus "n dvd x - y" by (simp add: dvd_eq_mod_eq_0)
next
assume H: "n dvd x - y"
then obtain k where k: "x-y = n*k" unfolding dvd_def by blast
hence "x = n*k + y" using diff_eq_eq by blast
hence "x mod n = (n*k + y) mod n" by simp
thus "x mod n = y mod n" by (simp add: mod_add_left_eq)
qed
lemma cong_gcd_eq_poly:
"gcd a m = gcd b m" if "[(a::'a mod_ring poly) = b] (mod m)"
using that by (simp add: cong_def) (metis gcd_mod_left mod_by_0)
lemma coprime_h_c_poly:
fixes h::"'a mod_ring poly"
assumes "c1 ≠ c2"
shows "coprime (h - [:c1:]) (h - [:c2:])"
proof (intro coprimeI)
fix d assume "d dvd h - [:c1:]"
and "d dvd h - [:c2:]"
hence "h mod d = [:c1:] mod d" and "h mod d = [:c2:] mod d"
using mod_eq_dvd_iff_poly by simp+
hence "[:c1:] mod d = [:c2:] mod d" by simp
hence "d dvd [:c2 - c1:]"
by (metis (no_types) mod_eq_dvd_iff_poly diff_pCons right_minus_eq)
thus "is_unit d"
by (metis (no_types) assms dvd_trans is_unit_monom_0 monom_0 right_minus_eq)
qed
lemma coprime_h_c_poly2:
fixes h::"'a mod_ring poly"
assumes "coprime (h - [:c1:]) (h - [:c2:])"
and "¬ is_unit (h - [:c1:])"
shows "c1 ≠ c2"
using assms coprime_id_is_unit by blast
lemma degree_minus_eq_right:
fixes p::"'b::ab_group_add poly"
shows "degree q < degree p ⟹ degree (p - q) = degree p"
using degree_add_eq_left[of "-q" p] degree_minus by auto
lemma coprime_prod:
fixes A::"'a mod_ring set" and g::"'a mod_ring ⇒ 'a mod_ring poly"
assumes "∀x∈A. coprime (g a) (g x)"
shows "coprime (g a) (prod (λx. g x) A)"
proof -
have f: "finite A" by simp
show ?thesis
using f using assms
proof (induct A)
case (insert x A)
have "(∏c∈insert x A. g c) = (g x) * (∏c∈A. g c)"
by (simp add: insert.hyps(2))
with insert.prems show ?case
by (auto simp: insert.hyps(3) prod_coprime_right)
qed auto
qed
lemma coprime_prod2:
fixes A::"'b::semiring_gcd set"
assumes "∀x∈A. coprime (a) (x)" and f: "finite A"
shows "coprime (a) (prod (λx. x) A)"
using f using assms
proof (induct A)
case (insert x A)
have "(∏c∈insert x A. c) = (x) * (∏c∈A. c)"
by (simp add: insert.hyps)
with insert.prems show ?case
by (simp add: insert.hyps prod_coprime_right)
qed auto
lemma divides_prod:
fixes g::"'a mod_ring ⇒ 'a mod_ring poly"
assumes "∀c1 c2. c1 ∈ A ∧ c2 ∈ A ∧ c1 ≠ c2 ⟶ coprime (g c1) (g c2)"
assumes "∀c∈ A. g c dvd f"
shows "(∏c∈A. g c) dvd f"
proof -
have finite_A: "finite A" using finite[of A] .
thus ?thesis using assms
proof (induct A)
case (insert x A)
have "(∏c∈insert x A. g c) = g x * (∏c∈ A. g c)"
by (simp add: insert.hyps(2))
also have "... dvd f"
proof (rule divides_mult)
show "g x dvd f" using insert.prems by auto
show "prod g A dvd f" using insert.hyps(3) insert.prems by auto
from insert show "Rings.coprime (g x) (prod g A)"
by (auto intro: prod_coprime_right)
qed
finally show ?case .
qed auto
qed
lemma poly_monom_identity_mod_p:
"monom (1::'a mod_ring) (CARD('a)) - monom 1 1 = prod (λx. [:0,1:] - [:x:]) (UNIV::'a mod_ring set)"
(is "?lhs = ?rhs")
proof -
let ?f="(λx::'a mod_ring. [:0,1:] - [:x:])"
have "?rhs dvd ?lhs"
proof (rule divides_prod)
{
fix a::"'a mod_ring"
have "poly ?lhs a = 0"
by (simp add: poly_monom)
hence "([:0,1:] - [:a:]) dvd ?lhs"
using poly_eq_0_iff_dvd by fastforce
}
thus "∀x∈UNIV::'a mod_ring set. [:0, 1:] - [:x:] dvd monom 1 CARD('a) - monom 1 1" by fast
show "∀c1 c2. c1 ∈ UNIV ∧ c2 ∈ UNIV ∧ c1 ≠ (c2 :: 'a mod_ring) ⟶ coprime ([:0, 1:] - [:c1:]) ([:0, 1:] - [:c2:])"
by (auto dest!: coprime_h_c_poly[of _ _ "[:0,1:]"])
qed
from this obtain g where g: "?lhs = ?rhs * g" using dvdE by blast
have degree_lhs_card: "degree ?lhs = CARD('a)"
proof -
have "degree (monom (1::'a mod_ring) 1) = 1" by (simp add: degree_monom_eq)
moreover have d_c: "degree (monom (1::'a mod_ring) CARD('a)) = CARD('a)"
by (simp add: degree_monom_eq)
ultimately have "degree (monom (1::'a mod_ring) 1) < degree (monom (1::'a mod_ring) CARD('a))"
using prime_card unfolding prime_nat_iff by auto
hence "degree ?lhs = degree (monom (1::'a mod_ring) CARD('a))"
by (rule degree_minus_eq_right)
thus ?thesis unfolding d_c .
qed
have degree_rhs_card: "degree ?rhs = CARD('a)"
proof -
have "degree (prod ?f UNIV) = sum (degree ∘ ?f) UNIV
∧ coeff (prod ?f UNIV) (sum (degree ∘ ?f) UNIV) = 1"
by (rule degree_prod_sum_monic, auto)
moreover have "sum (degree ∘ ?f) UNIV = CARD('a)" by auto
ultimately show ?thesis by presburger
qed
have monic_lhs: "monic ?lhs" using degree_lhs_card by auto
have monic_rhs: "monic ?rhs" by (rule monic_prod, simp)
have degree_eq: "degree ?rhs = degree ?lhs" unfolding degree_lhs_card degree_rhs_card ..
have g_not_0: "g ≠ 0" using g monic_lhs by auto
have degree_g0: "degree g = 0"
proof -
have "degree (?rhs * g) = degree ?rhs + degree g"
by (rule degree_monic_mult[OF monic_rhs g_not_0])
thus ?thesis using degree_eq g by simp
qed
have monic_g: "monic g" using monic_factor g monic_lhs monic_rhs by auto
have "g = 1" using monic_degree_0[OF monic_g] degree_g0 by simp
thus ?thesis using g by auto
qed
lemma poly_identity_mod_p:
"v^(CARD('a)) - v = prod (λx. v - [:x:]) (UNIV::'a mod_ring set)"
proof -
have id: "monom 1 1 ∘⇩p v = v" "[:0, 1:] ∘⇩p v = v" unfolding pcompose_def
apply (auto)
by (simp add: fold_coeffs_def)
have id2: "monom 1 (CARD('a)) ∘⇩p v = v ^ (CARD('a))" by (metis id(1) pcompose_hom.hom_power x_pow_n)
show ?thesis using arg_cong[OF poly_monom_identity_mod_p, of "λ f. f ∘⇩p v"]
unfolding pcompose_hom.hom_minus pcompose_hom.hom_prod id pcompose_const id2 .
qed
lemma coprime_gcd:
fixes h::"'a mod_ring poly"
assumes "Rings.coprime (h-[:c1:]) (h-[:c2:])"
shows "Rings.coprime (gcd f(h-[:c1:])) (gcd f (h-[:c2:]))"
using assms coprime_divisors by blast
lemma divides_prod_gcd:
fixes h::"'a mod_ring poly"
assumes "∀c1 c2. c1 ∈ A ∧ c2 ∈ A ∧ c1 ≠ c2⟶ coprime (h-[:c1:]) (h-[:c2:])"
shows "(∏c∈A. gcd f (h - [:c:])) dvd f"
proof -
have finite_A: "finite A" using finite[of A] .
thus ?thesis using assms
proof (induct A)
case (insert x A)
have "(∏c∈insert x A. gcd f (h - [:c:])) = (gcd f (h - [:x:])) * (∏c∈ A. gcd f (h - [:c:]))"
by (simp add: insert.hyps(2))
also have "... dvd f"
proof (rule divides_mult)
show "gcd f (h - [:x:]) dvd f" by simp
show "(∏c∈A. gcd f (h - [:c:])) dvd f" using insert.hyps(3) insert.prems by auto
show "Rings.coprime (gcd f (h - [:x:])) (∏c∈A. gcd f (h - [:c:]))"
by (rule prod_coprime_right)
(metis Berlekamp_Type_Based.coprime_h_c_poly coprime_gcd coprime_iff_coprime insert.hyps(2))
qed
finally show ?case .
qed auto
qed
lemma monic_prod_gcd:
assumes f: "finite A" and f0: "(f :: 'b :: {field_gcd} poly) ≠ 0"
shows "monic (∏c∈A. gcd f (h - [:c:]))"
using f
proof (induct A)
case (insert x A)
have rw: "(∏c∈insert x A. gcd f (h - [:c:]))
= (gcd f (h - [:x:])) * (∏c∈ A. gcd f (h - [:c:]))"
by (simp add: insert.hyps)
show ?case
proof (unfold rw, rule monic_mult)
show "monic (gcd f (h - [:x:]))"
using poly_gcd_monic[of f] f0
using insert.prems insert_iff by blast
show "monic (∏c∈A. gcd f (h - [:c:]))"
using insert.hyps(3) insert.prems by blast
qed
qed auto
lemma coprime_not_unit_not_dvd:
fixes a::"'b::semiring_gcd"
assumes "a dvd b"
and "coprime b c"
and "¬ is_unit a"
shows "¬ a dvd c"
using assms coprime_divisors coprime_id_is_unit by fastforce
lemma divides_prod2:
fixes A::"'b::semiring_gcd set"
assumes f: "finite A"
and "∀a∈A. a dvd c"
and "∀a1 a2. a1 ∈ A ∧ a2 ∈ A ∧ a1 ≠ a2 ⟶ coprime a1 a2"
shows "∏A dvd c"
using assms
proof (induct A)
case (insert x A)
have "∏(insert x A) = x * ∏A" by (simp add: insert.hyps(1) insert.hyps(2))
also have "... dvd c"
proof (rule divides_mult)
show "x dvd c" by (simp add: insert.prems)
show "∏A dvd c" using insert by auto
from insert show "Rings.coprime x (∏A)"
by (auto intro: prod_coprime_right)
qed
finally show ?case .
qed auto
lemma coprime_polynomial_factorization:
fixes a1 :: "'b :: {field_gcd} poly"
assumes irr: "as ⊆ {q. irreducible q ∧ monic q}"
and "finite as" and a1: "a1 ∈ as" and a2: "a2 ∈ as" and a1_not_a2: "a1 ≠ a2"
shows "coprime a1 a2"
proof (rule ccontr)
assume not_coprime: "¬ coprime a1 a2"
let ?b= "gcd a1 a2"
have b_dvd_a1: "?b dvd a1" and b_dvd_a2: "?b dvd a2" by simp+
have irr_a1: "irreducible a1" using a1 irr by blast
have irr_a2: "irreducible a2" using a2 irr by blast
have a2_not0: "a2 ≠ 0" using a2 irr by auto
have degree_a1: "degree a1 ≠ 0" using irr_a1 by auto
have degree_a2: "degree a2 ≠ 0" using irr_a2 by auto
have not_a2_dvd_a1: "¬ a2 dvd a1"
proof (rule ccontr, simp)
assume a2_dvd_a1: "a2 dvd a1"
from this obtain k where k: "a1 = a2 * k" unfolding dvd_def by auto
have k_not0: "k ≠ 0" using degree_a1 k by auto
show False
proof (cases "degree a2 = degree a1")
case False
have "degree a2 < degree a1"
using False a2_dvd_a1 degree_a1 divides_degree
by fastforce
hence "¬ irreducible a1"
using degree_a2 a2_dvd_a1 degree_a2
by (metis degree_a1 irreducible⇩dD(2) irreducible⇩d_multD irreducible_connect_field k neq0_conv)
thus False using irr_a1 by contradiction
next
case True
have "degree a1 = degree a2 + degree k"
unfolding k using degree_mult_eq[OF a2_not0 k_not0] by simp
hence "degree k = 0" using True by simp
hence "k = 1" using monic_factor a1 a2 irr k monic_degree_0 by auto
hence "a1 = a2" using k by simp
thus False using a1_not_a2 by contradiction
qed
qed
have b_not0: "?b ≠ 0" by (simp add: a2_not0)
have degree_b: "degree ?b > 0"
using not_coprime[simplified] b_not0 is_unit_gcd is_unit_iff_degree by blast
have "degree ?b < degree a2"
by (meson b_dvd_a1 b_dvd_a2 irreducibleD' dvd_trans gcd_dvd_1 irr_a2 not_a2_dvd_a1 not_coprime)
hence "¬ irreducible⇩d a2" using degree_a2 b_dvd_a2 degree_b
by (metis degree_smult_eq irreducible⇩d_dvd_smult less_not_refl3)
thus False using irr_a2 by auto
qed
theorem Berlekamp_gcd_step:
fixes f::"'a mod_ring poly" and h::"'a mod_ring poly"
assumes hq_mod_f: "[h^(CARD('a)) = h] (mod f)" and monic_f: "monic f" and sf_f: "square_free f"
shows "f = prod (λc. gcd f (h - [:c:])) (UNIV::'a mod_ring set)" (is "?lhs = ?rhs")
proof (cases "f=0")
case True
thus ?thesis using coeff_0 monic_f zero_neq_one by auto
next
case False note f_not_0 = False
show ?thesis
proof (rule poly_dvd_antisym)
show "?rhs dvd f"
using coprime_h_c_poly by (intro divides_prod_gcd, auto)
have "monic ?rhs" by (rule monic_prod_gcd[OF _ f_not_0], simp)
thus "coeff f (degree f) = coeff ?rhs (degree ?rhs)"
using monic_f by auto
next
show "f dvd ?rhs"
proof -
let ?p = "CARD('a)"
obtain P where finite_P: "finite P"
and f_desc_square_free: "f = (∏a∈P. a)"
and P: "P ⊆ {q. irreducible q ∧ monic q}"
using monic_square_free_irreducible_factorization[OF monic_f sf_f] by auto
have f_dvd_hqh: "f dvd (h^?p - h)" using hq_mod_f unfolding cong_def
using mod_eq_dvd_iff_poly by blast
also have hq_h_rw: "... = prod (λc. h - [:c:]) (UNIV::'a mod_ring set)"
by (rule poly_identity_mod_p)
finally have f_dvd_hc: "f dvd prod (λc. h - [:c:]) (UNIV::'a mod_ring set)" by simp
have "f = ∏P" using f_desc_square_free by simp
also have "... dvd ?rhs"
proof (rule divides_prod2[OF finite_P])
show "∀a1 a2. a1 ∈ P ∧ a2 ∈ P ∧ a1 ≠ a2 ⟶ coprime a1 a2"
using coprime_polynomial_factorization[OF P finite_P] by simp
show "∀a∈P. a dvd (∏c∈UNIV. gcd f (h - [:c:]))"
proof
fix fi assume fi_P: "fi ∈ P"
show "fi dvd ?rhs"
proof (rule dvd_prod, auto)
show "fi dvd f" using f_desc_square_free fi_P
using dvd_prod_eqI finite_P by blast
hence "fi dvd (h^?p - h)" using dvd_trans f_dvd_hqh by auto
also have "... = prod (λc. h - [:c:]) (UNIV::'a mod_ring set)"
unfolding hq_h_rw by simp
finally have fi_dvd_prod_hc: "fi dvd prod (λc. h - [:c:]) (UNIV::'a mod_ring set)" .
have irr_fi: "irreducible (fi)" using fi_P P by blast
have fi_not_unit: "¬ is_unit fi" using irr_fi by (simp add: irreducible⇩dD(1) poly_dvd_1)
have fi_dvd_hc: "∃c∈UNIV::'a mod_ring set. fi dvd (h-[:c:])"
by (rule irreducible_dvd_prod[OF _ fi_dvd_prod_hc], simp add: irr_fi)
thus "∃c. fi dvd h - [:c:]" by simp
qed
qed
qed
finally show "f dvd ?rhs" .
qed
qed
qed
subsection ‹Definitions›
definition berlekamp_mat :: "'a mod_ring poly ⇒ 'a mod_ring mat" where
"berlekamp_mat u = (let n = degree u;
mul_p = power_poly_f_mod u [:0,1:] (CARD('a));
xks = power_polys mul_p u 1 n
in
mat_of_rows_list n (map (λ cs. let coeffs_cs = (coeffs cs);
k = n - length (coeffs cs)
in (coeffs cs) @ replicate k 0) xks))"
definition berlekamp_resulting_mat :: "('a mod_ring) poly ⇒ 'a mod_ring mat" where
"berlekamp_resulting_mat u = (let Q = berlekamp_mat u;
n = dim_row Q;
QI = mat n n (λ (i,j). if i = j then Q $$ (i,j) - 1 else Q $$ (i,j))
in (gauss_jordan_single (transpose_mat QI)))"
definition berlekamp_basis :: "'a mod_ring poly ⇒ 'a mod_ring poly list" where
"berlekamp_basis u = (map (Poly o list_of_vec) (find_base_vectors (berlekamp_resulting_mat u)))"
lemma berlekamp_basis_code[code]: "berlekamp_basis u =
(map (poly_of_list o list_of_vec) (find_base_vectors (berlekamp_resulting_mat u)))"
unfolding berlekamp_basis_def poly_of_list_def ..
primrec berlekamp_factorization_main :: "nat ⇒ 'a mod_ring poly list ⇒ 'a mod_ring poly list ⇒ nat ⇒ 'a mod_ring poly list" where
"berlekamp_factorization_main i divs (v # vs) n = (if v = 1 then berlekamp_factorization_main i divs vs n else
if length divs = n then divs else
let facts = [ w . u ← divs, s ← [0 ..< CARD('a)], w ← [gcd u (v - [:of_int s:])], w ≠ 1];
(lin,nonlin) = List.partition (λ q. degree q = i) facts
in lin @ berlekamp_factorization_main i nonlin vs (n - length lin))"
| "berlekamp_factorization_main i divs [] n = divs"
definition berlekamp_monic_factorization :: "nat ⇒ 'a mod_ring poly ⇒ 'a mod_ring poly list" where
"berlekamp_monic_factorization d f = (let
vs = berlekamp_basis f;
n = length vs;
fs = berlekamp_factorization_main d [f] vs n
in fs)"
subsection ‹Properties›
lemma power_polys_works:
fixes u::"'b::unique_euclidean_semiring"
assumes i: "i < n" and c: "curr_p = curr_p mod u"
shows "power_polys mult_p u curr_p n ! i = curr_p * mult_p ^ i mod u"
using i c
proof (induct n arbitrary: curr_p i)
case 0 thus ?case by simp
next
case (Suc n)
have p_rw: "power_polys mult_p u curr_p (Suc n) ! i
= (curr_p # power_polys mult_p u (curr_p * mult_p mod u) n) ! i"
by simp
show ?case
proof (cases "i=0")
case True
show ?thesis using Suc.prems unfolding p_rw True by auto
next
case False note i_not_0 = False
show ?thesis
proof (cases "i < n")
case True note i_less_n = True
have "power_polys mult_p u curr_p (Suc n) ! i = power_polys mult_p u (curr_p * mult_p mod u) n ! (i - 1)"
unfolding p_rw using nth_Cons_pos False by auto
also have "... = (curr_p * mult_p mod u) * mult_p ^ (i-1) mod u"
by (rule Suc.hyps) (auto simp add: i_less_n less_imp_diff_less)
also have "... = curr_p * mult_p ^ i mod u"
using False by (cases i) (simp_all add: algebra_simps mod_simps)
finally show ?thesis .
next
case False
hence i_n: "i = n" using Suc.prems by auto
have "power_polys mult_p u curr_p (Suc n) ! i = power_polys mult_p u (curr_p * mult_p mod u) n ! (n - 1)"
unfolding p_rw using nth_Cons_pos i_n i_not_0 by auto
also have "... = (curr_p * mult_p mod u) * mult_p ^ (n-1) mod u"
proof (rule Suc.hyps)
show "n - 1 < n" using i_n i_not_0 by linarith
show "curr_p * mult_p mod u = curr_p * mult_p mod u mod u" by simp
qed
also have "... = curr_p * mult_p ^ i mod u"
using i_n [symmetric] i_not_0 by (cases i) (simp_all add: algebra_simps mod_simps)
finally show ?thesis .
qed
qed
qed
lemma length_power_polys[simp]: "length (power_polys mult_p u curr_p n) = n"
by (induct n arbitrary: curr_p, auto)
lemma Poly_berlekamp_mat:
assumes k: "k < degree u"
shows "Poly (list_of_vec (row (berlekamp_mat u) k)) = [:0,1:]^(CARD('a) * k) mod u"
proof -
let ?map ="(map (λcs. coeffs cs @ replicate (degree u - length (coeffs cs)) 0)
(power_polys (power_poly_f_mod u [:0, 1:] (nat (int CARD('a)))) u 1 (degree u)))"
have "row (berlekamp_mat u) k = row (mat_of_rows_list (degree u) ?map) k"
by (simp add: berlekamp_mat_def Let_def)
also have "... = vec_of_list (?map ! k)"
proof-
{
fix i assume i: "i < degree u"
let ?c= "power_polys (power_poly_f_mod u [:0, 1:] CARD('a)) u 1 (degree u) ! i"
let ?coeffs_c="(coeffs ?c)"
have "?c = 1*([:0, 1:] ^ CARD('a) mod u)^i mod u"
proof (unfold power_poly_f_mod_def, rule power_polys_works[OF i])
show "1 = 1 mod u" using k mod_poly_less by force
qed
also have "... = [:0, 1:] ^ (CARD('a) * i) mod u" by (simp add: power_mod power_mult)
finally have c_rw: "?c = [:0, 1:] ^ (CARD('a) * i) mod u" .
have "length ?coeffs_c ≤ degree u"
proof -
show ?thesis
proof (cases "?c = 0")
case True thus ?thesis by auto
next
case False
have "length ?coeffs_c = degree (?c) + 1" by (rule length_coeffs[OF False])
also have "... = degree ([:0, 1:] ^ (CARD('a) * i) mod u) + 1" using c_rw by simp
also have "... ≤ degree u"
by (metis One_nat_def add.right_neutral add_Suc_right c_rw calculation coeffs_def degree_0
degree_mod_less discrete gr_implies_not0 k list.size(3) one_neq_zero)
finally show ?thesis .
qed
qed
then have "length ?coeffs_c + (degree u - length ?coeffs_c) = degree u" by auto
}
with k show ?thesis by (intro row_mat_of_rows_list, auto)
qed
finally have row_rw: "row (berlekamp_mat u) k = vec_of_list (?map ! k)" .
have "Poly (list_of_vec (row (berlekamp_mat u) k)) = Poly (list_of_vec (vec_of_list (?map ! k)))"
unfolding row_rw ..
also have "... = Poly (?map ! k)" by simp
also have "... = [:0,1:]^(CARD('a) * k) mod u"
proof -
let ?cs = "(power_polys (power_poly_f_mod u [:0, 1:] (nat (int CARD('a)))) u 1 (degree u)) ! k"
let ?c = "coeffs ?cs @ replicate (degree u - length (coeffs ?cs)) 0"
have map_k_c: "?map ! k = ?c" by (rule nth_map, simp add: k)
have "(Poly (?map ! k)) = Poly (coeffs ?cs)" unfolding map_k_c Poly_append_replicate_0 ..
also have "... = ?cs" by simp
also have "... = power_polys ([:0, 1:] ^ CARD('a) mod u) u 1 (degree u) ! k"
by (simp add: power_poly_f_mod_def)
also have "... = 1* ([:0,1:]^(CARD('a)) mod u) ^ k mod u"
proof (rule power_polys_works[OF k])
show "1 = 1 mod u" using k mod_poly_less by force
qed
also have "... = ([:0,1:]^(CARD('a)) mod u) ^ k mod u" by auto
also have "... = [:0,1:]^(CARD('a) * k) mod u" by (simp add: power_mod power_mult)
finally show ?thesis .
qed
finally show ?thesis .
qed
corollary Poly_berlekamp_cong_mat:
assumes k: "k < degree u"
shows "[Poly (list_of_vec (row (berlekamp_mat u) k)) = [:0,1:]^(CARD('a) * k)] (mod u)"
using Poly_berlekamp_mat[OF k] unfolding cong_def by auto
lemma mat_of_rows_list_dim[simp]:
"mat_of_rows_list n vs ∈ carrier_mat (length vs) n"
"dim_row (mat_of_rows_list n vs) = length vs"
"dim_col (mat_of_rows_list n vs) = n"
unfolding mat_of_rows_list_def by auto
lemma berlekamp_mat_closed[simp]:
"berlekamp_mat u ∈ carrier_mat (degree u) (degree u)"
"dim_row (berlekamp_mat u) = degree u"
"dim_col (berlekamp_mat u) = degree u"
unfolding carrier_mat_def berlekamp_mat_def Let_def by auto
lemma vec_of_list_coeffs_nth:
assumes i: "i ∈ {..degree h}" and h_not0: "h ≠ 0"
shows "vec_of_list (coeffs h) $ i = coeff h i"
proof -
have "vec_of_list (map (coeff h) [0..<degree h] @ [coeff h (degree h)]) $ i = coeff h i"
using i
by (transfer', auto simp add: mk_vec_def)
(metis (no_types, lifting) Cons_eq_append_conv coeffs_def coeffs_nth degree_0
diff_zero length_upt less_eq_nat.simps(1) list.simps(8) list.simps(9) map_append
nth_Cons_0 upt_Suc upt_eq_Nil_conv)
thus "vec_of_list (coeffs h) $ i = coeff h i"
using i h_not0
unfolding coeffs_def by simp
qed
lemma poly_mod_sum:
fixes x y z :: "'b::field poly"
assumes f: "finite A"
shows "sum f A mod z = sum (λi. f i mod z) A"
using f
by (induct, auto simp add: poly_mod_add_left)
lemma prime_not_dvd_fact:
assumes kn: "k < n" and prime_n: "prime n"
shows "¬ n dvd fact k"
using kn
proof (induct k)
case 0
thus ?case using prime_n unfolding prime_nat_iff by auto
next
case (Suc k)
show ?case
proof (rule ccontr, unfold not_not)
assume "n dvd fact (Suc k)"
also have "... = Suc k * ∏{1..k}" unfolding fact_Suc unfolding fact_prod by simp
finally have "n dvd Suc k * ∏{1..k}" .
hence "n dvd Suc k ∨ n dvd ∏{1..k}" using prime_dvd_mult_eq_nat[OF prime_n] by blast
moreover have "¬ n dvd Suc k" by (simp add: Suc.prems(1) nat_dvd_not_less)
moreover hence "¬ n dvd ∏{1..k}" using Suc.hyps Suc.prems
using Suc_lessD fact_prod[of k] by (metis of_nat_id)
ultimately show False by simp
qed
qed
lemma dvd_choose_prime:
assumes kn: "k < n" and k: "k ≠ 0" and n: "n ≠ 0" and prime_n: "prime n"
shows "n dvd (n choose k)"
proof -
have "n dvd (fact n)" by (simp add: fact_num_eq_if n)
moreover have "¬ n dvd (fact k * fact (n-k))"
proof (rule ccontr, simp)
assume "n dvd fact k * fact (n - k)"
hence "n dvd fact k ∨ n dvd fact (n - k)" using prime_dvd_mult_eq_nat[OF prime_n] by simp
moreover have "¬ n dvd (fact k)" by (rule prime_not_dvd_fact[OF kn prime_n])
moreover have "¬ n dvd fact (n - k)" using prime_not_dvd_fact[OF _ prime_n] kn k by simp
ultimately show False by simp
qed
moreover have "(fact n::nat) = fact k * fact (n-k) * (n choose k)"
using binomial_fact_lemma kn by auto
ultimately show ?thesis using prime_n
by (auto simp add: prime_dvd_mult_iff)
qed
lemma add_power_poly_mod_ring:
fixes x :: "'a mod_ring poly"
shows "(x + y) ^ CARD('a) = x ^ CARD('a) + y ^ CARD('a)"
proof -
let ?A="{0..CARD('a)}"
let ?f="λk. of_nat (CARD('a) choose k) * x ^ k * y ^ (CARD('a) - k)"
have A_rw: "?A = insert CARD('a) (insert 0 (?A - {0} - {CARD('a)}))"
by fastforce
have sum0: "sum ?f (?A - {0} - {CARD('a)}) = 0"
proof (rule sum.neutral, rule)
fix xa assume xa: "xa ∈ {0..CARD('a)} - {0} - {CARD('a)}"
have card_dvd_choose: "CARD('a) dvd (CARD('a) choose xa)"
proof (rule dvd_choose_prime)
show "xa < CARD('a)" using xa by simp
show "xa ≠ 0" using xa by simp
show "CARD('a) ≠ 0" by simp
show "prime CARD('a)" by (rule prime_card)
qed
hence rw0: "of_int (CARD('a) choose xa) = (0 :: 'a mod_ring)"
by transfer simp
have "of_nat (CARD('a) choose xa) = [:of_int (CARD('a) choose xa) :: 'a mod_ring:]"
by (simp add: of_nat_poly)
also have "... = [:0:]" using rw0 by simp
finally show "of_nat (CARD('a) choose xa) * x ^ xa * y ^ (CARD('a) - xa) = 0" by auto
qed
have "(x + y)^CARD('a)
= (∑k = 0..CARD('a). of_nat (CARD('a) choose k) * x ^ k * y ^ (CARD('a) - k))"
unfolding binomial_ring by (rule sum.cong, auto)
also have "... = sum ?f (insert CARD('a) (insert 0 (?A - {0} - {CARD('a)})))"
using A_rw by simp
also have "... = ?f 0 + ?f CARD('a) + sum ?f (?A - {0} - {CARD('a)})" by auto
also have "... = x^CARD('a) + y^CARD('a)" unfolding sum0 by auto
finally show ?thesis .
qed
lemma power_poly_sum_mod_ring:
fixes f :: "'b ⇒ 'a mod_ring poly"
assumes f: "finite A"
shows "(sum f A) ^ CARD('a) = sum (λi. (f i) ^ CARD('a)) A"
using f by (induct, auto simp add: add_power_poly_mod_ring)
lemma poly_power_card_as_sum_of_monoms:
fixes h :: "'a mod_ring poly"
shows "h ^ CARD('a) = (∑i≤degree h. monom (coeff h i) (CARD('a)*i))"
proof -
have "h ^ CARD('a) = (∑i≤degree h. monom (coeff h i) i) ^ CARD('a)"
by (simp add: poly_as_sum_of_monoms)
also have "... = (∑i≤degree h. (monom (coeff h i) i) ^ CARD('a))"
by (simp add: power_poly_sum_mod_ring)
also have "... = (∑i≤degree h. monom (coeff h i) (CARD('a)*i))"
proof (rule sum.cong, rule)
fix x assume x: "x ∈ {..degree h}"
show "monom (coeff h x) x ^ CARD('a) = monom (coeff h x) (CARD('a) * x)"
by (unfold poly_eq_iff, auto simp add: monom_power)
qed
finally show ?thesis .
qed
lemma degree_Poly_berlekamp_le:
assumes i: "i < degree u"
shows "degree (Poly (list_of_vec (row (berlekamp_mat u) i))) < degree u"
by (metis Poly_berlekamp_mat degree_0 degree_mod_less gr_implies_not0 i linorder_neqE_nat)
lemma monom_card_pow_mod_sum_berlekamp:
assumes i: "i < degree u"
shows "monom 1 (CARD('a) * i) mod u = (∑j<degree u. monom ((berlekamp_mat u) $$ (i,j)) j)"
proof -
let ?p = "Poly (list_of_vec (row (berlekamp_mat u) i))"
have degree_not_0: "degree u ≠ 0" using i by simp
hence set_rw: "{..degree u - 1} = {..<degree u}" by auto
have degree_le: "degree ?p < degree u"
by (rule degree_Poly_berlekamp_le[OF i])
hence degree_le2: "degree ?p ≤ degree u - 1" by auto
have "monom 1 (CARD('a) * i) mod u = [:0, 1:] ^ (CARD('a) * i) mod u"
using x_as_monom x_pow_n by metis
also have "... = ?p"
unfolding Poly_berlekamp_mat[OF i] by simp
also have "... = (∑i≤degree u - 1. monom (coeff ?p i) i)"
using degree_le2 poly_as_sum_of_monoms' by fastforce
also have "... = (∑i<degree u. monom (coeff ?p i) i)" using set_rw by auto
also have "... = (∑j<degree u. monom ((berlekamp_mat u) $$ (i,j)) j)"
proof (rule sum.cong, rule)
fix x assume x: "x ∈ {..<degree u}"
have "coeff ?p x = berlekamp_mat u $$ (i, x)"
proof (rule coeff_Poly_list_of_vec_nth)
show "x < dim_col (berlekamp_mat u)" using x by auto
qed
thus "monom (coeff ?p x) x = monom (berlekamp_mat u $$ (i, x)) x"
by (simp add: poly_eq_iff)
qed
finally show ?thesis .
qed
lemma col_scalar_prod_as_sum:
assumes "dim_vec v = dim_row A"
shows "col A j ∙ v = (∑i = 0..<dim_vec v. A $$ (i,j) * v $ i)"
using assms
unfolding col_def scalar_prod_def
by transfer' (rule sum.cong, transfer', auto simp add: mk_vec_def mk_mat_def )
lemma row_transpose_scalar_prod_as_sum:
assumes j: "j < dim_col A" and dim_v: "dim_vec v = dim_row A"
shows "row (transpose_mat A) j ∙ v = (∑i = 0..<dim_vec v. A $$ (i,j) * v $ i)"
proof -
have "row (transpose_mat A) j ∙ v = col A j ∙ v" using j row_transpose by auto
also have "... = (∑i = 0..<dim_vec v. A $$ (i,j) * v $ i)"
by (rule col_scalar_prod_as_sum[OF dim_v])
finally show ?thesis .
qed
lemma poly_as_sum_eq_monoms:
assumes ss_eq: "(∑i<n. monom (f i) i) = (∑i<n. monom (g i) i)"
and a_less_n: "a<n"
shows "f a = g a"
proof -
let ?f="λi. if i = a then f i else 0"
let ?g="λi. if i = a then g i else 0"
have sum_f_0: "sum ?f ({..<n} - {a}) = 0" by (rule sum.neutral, auto)
have "coeff (∑i<n. monom (f i) i) a = coeff (∑i<n. monom (g i) i) a"
using ss_eq unfolding poly_eq_iff by simp
hence "(∑i<n. coeff (monom (f i) i) a) = (∑i<n. coeff (monom (g i) i) a)"
by (simp add: coeff_sum)
hence 1: "(∑i<n. if i = a then f i else 0) = (∑i<n. if i = a then g i else 0)"
unfolding coeff_monom by auto
have set_rw: "{..<n} = (insert a ({..<n} - {a}))" using a_less_n by auto
have "(∑i<n. if i = a then f i else 0) = sum ?f (insert a ({..<n} - {a}))"
using set_rw by auto
also have "... = ?f a + sum ?f ({..<n} - {a})"
by (simp add: sum.insert_remove)
also have "... = ?f a" using sum_f_0 by simp
finally have 2: "(∑i<n. if i = a then f i else 0) = ?f a" .
have "sum ?g {..<n} = sum ?g (insert a ({..<n} - {a}))"
using set_rw by auto
also have "... = ?g a + sum ?g ({..<n} - {a})"
by (simp add: sum.insert_remove)
also have "... = ?g a" using sum_f_0 by simp
finally have 3: "(∑i<n. if i = a then g i else 0) = ?g a" .
show ?thesis using 1 2 3 by auto
qed
lemma dim_vec_of_list_h:
assumes "degree h < degree u"
shows "dim_vec (vec_of_list ((coeffs h) @ replicate (degree u - length (coeffs h)) 0)) = degree u"
proof -
have "length (coeffs h) ≤ degree u"
by (metis Suc_leI assms coeffs_0_eq_Nil degree_0 length_coeffs_degree
list.size(3) not_le_imp_less order.asym)
thus ?thesis by simp
qed
lemma vec_of_list_coeffs_nth':
assumes i: "i ∈ {..degree h}" and h_not0: "h ≠ 0"
assumes "degree h < degree u"
shows "vec_of_list ((coeffs h) @ replicate (degree u - length (coeffs h)) 0) $ i = coeff h i"
using assms
by (transfer', auto simp add: mk_vec_def coeffs_nth length_coeffs_degree nth_append)
lemma vec_of_list_coeffs_replicate_nth_0:
assumes i: "i ∈ {..<degree u}"
shows "vec_of_list (coeffs 0 @ replicate (degree u - length (coeffs 0)) 0) $ i = coeff 0 i"
using assms
by (transfer', auto simp add: mk_vec_def)
lemma vec_of_list_coeffs_replicate_nth:
assumes i: "i ∈ {..<degree u}"
assumes "degree h < degree u"
shows "vec_of_list ((coeffs h) @ replicate (degree u - length (coeffs h)) 0) $ i = coeff h i"
proof (cases "h = 0")
case True
thus ?thesis using vec_of_list_coeffs_replicate_nth_0 i by auto
next
case False note h_not0 = False
show ?thesis
proof (cases "i ∈{..degree h}")
case True thus ?thesis using assms vec_of_list_coeffs_nth' h_not0 by simp
next
case False
have c0: "coeff h i = 0" using False le_degree by auto
thus ?thesis
using assms False h_not0
by (transfer', auto simp add: mk_vec_def length_coeffs_degree nth_append c0)
qed
qed
lemma equation_13:
fixes u h
defines H: "H ≡ vec_of_list ((coeffs h) @ replicate (degree u - length (coeffs h)) 0)"
assumes deg_le: "degree h < degree u"
shows "[h^CARD('a) = h] (mod u) ⟷ (transpose_mat (berlekamp_mat u)) *⇩v H = H"
(is "?lhs = ?rhs")
proof -
have f: "finite {..degree u}" by auto
have [simp]: "dim_vec H = degree u" unfolding H using dim_vec_of_list_h deg_le by simp
let ?B = "(berlekamp_mat u)"
let ?f = "λi. (transpose_mat ?B *⇩v H) $ i"
show ?thesis
proof
assume rhs: ?rhs
have dimv_h_dimr_B: "dim_vec H = dim_row ?B"
by (metis berlekamp_mat_closed(2) berlekamp_mat_closed(3)
dim_mult_mat_vec index_transpose_mat(2) rhs)
have degree_h_less_dim_H: "degree h < dim_vec H" by (auto simp add: deg_le)
have set_rw: "{..degree u - 1} = {..<degree u}" using deg_le by auto
have "degree h ≤ degree u - 1" using deg_le by simp
hence "h = (∑j≤degree u - 1. monom (coeff h j) j)" using poly_as_sum_of_monoms' by fastforce
also have "... = (∑j<degree u. monom (coeff h j) j)" using set_rw by simp
also have "... = (∑j<degree u. monom (?f j) j)"
proof (rule sum.cong, rule+)
fix j assume i: "j ∈ {..<degree u}"
have "(coeff h j) = ?f j"
using rhs vec_of_list_coeffs_replicate_nth[OF i deg_le]
unfolding H by presburger
thus "monom (coeff h j) j = monom (?f j) j"
by simp
qed
also have "... = (∑j<degree u. monom (row (transpose_mat ?B) j ∙ H) j)"
by (rule sum.cong, auto)
also have "... = (∑j<degree u. monom (∑i = 0..<dim_vec H. ?B $$ (i,j) * H $ i) j)"
proof (rule sum.cong, rule)
fix x assume x: "x ∈ {..<degree u}"
show "monom (row (transpose_mat ?B) x ∙ H) x =
monom (∑i = 0..<dim_vec H. ?B $$ (i, x) * H $ i) x"
proof (unfold monom_eq_iff, rule row_transpose_scalar_prod_as_sum[OF _ dimv_h_dimr_B])
show "x < dim_col ?B" using x deg_le by auto
qed
qed
also have "... = (∑j<degree u. ∑i = 0..<dim_vec H. monom (?B $$ (i,j) * H $ i) j)"
by (auto simp add: monom_sum)
also have "... = (∑i = 0..<dim_vec H. ∑j<degree u. monom (?B $$ (i,j) * H $ i) j)"
by (rule sum.swap)
also have "... = (∑i = 0..<dim_vec H. ∑j<degree u. monom (H $ i) 0 * monom (?B $$ (i,j)) j)"
proof (rule sum.cong, rule, rule sum.cong, rule)
fix x xa
show "monom (?B $$ (x, xa) * H $ x) xa = monom (H $ x) 0 * monom (?B $$ (x, xa)) xa"
by (simp add: mult_monom)
qed
also have "... = (∑i = 0..<dim_vec H. (monom (H $ i) 0) * (∑j<degree u. monom (?B $$ (i,j)) j))"
by (rule sum.cong, auto simp: sum_distrib_left)
also have "... = (∑i = 0..<dim_vec H. (monom (H $ i) 0) * (monom 1 (CARD('a) * i) mod u))"
proof (rule sum.cong, rule)
fix x assume x: "x ∈ {0..<dim_vec H}"
have "(∑j<degree u. monom (?B $$ (x, j)) j) = (monom 1 (CARD('a) * x) mod u)"
proof (rule monom_card_pow_mod_sum_berlekamp[symmetric])
show "x < degree u" using x dimv_h_dimr_B by auto
qed
thus "monom (H $ x) 0 * (∑j<degree u. monom (?B $$ (x, j)) j) =
monom (H $ x) 0 * (monom 1 (CARD('a) * x) mod u)" by presburger
qed
also have "... = (∑i = 0..<dim_vec H. monom (H $ i) (CARD('a) * i) mod u)"
proof (rule sum.cong, rule)
fix x
have h_rw: "monom (H $ x) 0 mod u = monom (H $ x) 0"
by (metis deg_le degree_pCons_eq_if gr_implies_not_zero
linorder_neqE_nat mod_poly_less monom_0)
have "monom (H $ x) (CARD('a) * x) = monom (H $ x) 0 * monom 1 (CARD('a) * x)"
unfolding mult_monom by simp
also have "... = smult (H $ x) (monom 1 (CARD('a) * x))"
by (simp add: monom_0)
also have "... mod u = Polynomial.smult (H $ x) (monom 1 (CARD('a) * x) mod u)"
using mod_smult_left by auto
also have "... = monom (H $ x) 0 * (monom 1 (CARD('a) * x) mod u)"
by (simp add: monom_0)
finally show "monom (H $ x) 0 * (monom 1 (CARD('a) * x) mod u)
= monom (H $ x) (CARD('a) * x) mod u" ..
qed
also have "... = (∑i = 0..<dim_vec H. monom (H $ i) (CARD('a) * i)) mod u"
by (simp add: poly_mod_sum)
also have "... = (∑i = 0..<dim_vec H. monom (coeff h i) (CARD('a) * i)) mod u"
proof (rule arg_cong[of _ _ "λx. x mod u"], rule sum.cong, rule)
fix x assume x: "x ∈ {0..<dim_vec H}"
have "H $ x = (coeff h x)"
proof (unfold H, rule vec_of_list_coeffs_replicate_nth[OF _ deg_le])
show "x ∈ {..<degree u}" using x by auto
qed
thus "monom (H $ x) (CARD('a) * x) = monom (coeff h x) (CARD('a) * x)"
by simp
qed
also have "... = (∑i≤degree h. monom (coeff h i) (CARD('a) * i)) mod u"
proof (rule arg_cong[of _ _ "λx. x mod u"])
let ?f="λi. monom (coeff h i) (CARD('a) * i)"
have ss0: "(∑i = degree h + 1 ..< dim_vec H. ?f i) = 0"
by (rule sum.neutral, simp add: coeff_eq_0)
have set_rw: "{0..< dim_vec H} = {0..degree h} ∪ {degree h + 1 ..< dim_vec H}"
using degree_h_less_dim_H by auto
have "(∑i = 0..<dim_vec H. ?f i) = (∑i = 0..degree h. ?f i) + (∑i = degree h + 1 ..< dim_vec H. ?f i)"
unfolding set_rw by (rule sum.union_disjoint, auto)
also have "... = (∑i = 0..degree h. ?f i)" unfolding ss0 by auto
finally show "(∑i = 0..<dim_vec H. ?f i) = (∑i≤degree h. ?f i)"
by (simp add: atLeast0AtMost)
qed
also have "... = h^CARD('a) mod u"
using poly_power_card_as_sum_of_monoms by auto
finally show ?lhs
unfolding cong_def
using deg_le
by (simp add: mod_poly_less)
next
assume lhs: ?lhs
have deg_le': "degree h ≤ degree u - 1" using deg_le by auto
have set_rw: "{..<degree u} = {..degree u -1}" using deg_le by auto
hence "(∑i<degree u. monom (coeff h i) i) = (∑i ≤ degree u - 1. monom (coeff h i) i)" by simp
also have "... = (∑i≤degree h. monom (coeff h i) i)"
unfolding poly_as_sum_of_monoms
using poly_as_sum_of_monoms' deg_le' by auto
also have "... = (∑i≤degree h. monom (coeff h i) i) mod u"
by (simp add: deg_le mod_poly_less poly_as_sum_of_monoms)
also have "... = (∑i≤degree h. monom (coeff h i) (CARD('a)*i)) mod u"
using lhs
unfolding cong_def poly_as_sum_of_monoms poly_power_card_as_sum_of_monoms
by auto
also have "... = (∑i≤degree h. monom (coeff h i) 0 * monom 1 (CARD('a)*i)) mod u"
by (rule arg_cong[of _ _ "λx. x mod u"], rule sum.cong, simp_all add: mult_monom)
also have "... = (∑i≤degree h. monom (coeff h i) 0 * monom 1 (CARD('a)*i) mod u)"
by (simp add: poly_mod_sum)
also have "... = (∑i≤degree h. monom (coeff h i) 0 * (monom 1 (CARD('a)*i) mod u))"
proof (rule sum.cong, rule)
fix x assume x: "x ∈ {..degree h}"
have h_rw: "monom (coeff h x) 0 mod u = monom (coeff h x) 0"
by (metis deg_le degree_pCons_eq_if gr_implies_not_zero
linorder_neqE_nat mod_poly_less monom_0)
have "monom (coeff h x) 0 * monom 1 (CARD('a) * x) = smult (coeff h x) (monom 1 (CARD('a) * x))"
by (simp add: monom_0)
also have "... mod u = Polynomial.smult (coeff h x) (monom 1 (CARD('a) * x) mod u)"
using mod_smult_left by auto
also have "... = monom (coeff h x) 0 * (monom 1 (CARD('a) * x) mod u)"
by (simp add: monom_0)
finally show "monom (coeff h x) 0 * monom 1 (CARD('a) * x) mod u
= monom (coeff h x) 0 * (monom 1 (CARD('a) * x) mod u)" .
qed
also have "... = (∑i≤degree h. monom (coeff h i) 0 * (∑j<degree u. monom (?B $$ (i, j)) j))"
proof (rule sum.cong, rule)
fix x assume x: "x ∈ {..degree h}"
have "(monom 1 (CARD('a) * x) mod u) = (∑j<degree u. monom (?B $$ (x, j)) j)"
proof (rule monom_card_pow_mod_sum_berlekamp)
show " x < degree u" using x deg_le by auto
qed
thus "monom (coeff h x) 0 * (monom 1 (CARD('a) * x) mod u) =
monom (coeff h x) 0 * (∑j<degree u. monom (?B $$ (x, j)) j)" by simp
qed
also have "... = (∑i<degree u. monom (coeff h i) 0 * (∑j<degree u. monom (?B $$ (i, j)) j))"
proof -
let ?f="λi. monom (coeff h i) 0 * (∑j<degree u. monom (?B $$ (i, j)) j)"
have ss0: "(∑i=degree h+1 ..< degree u. ?f i) = 0"
by (rule sum.neutral, simp add: coeff_eq_0)
have set_rw: "{0..<degree u} = {0..degree h} ∪ {degree h+1..<degree u}" using deg_le by auto
have "(∑i=0..<degree u. ?f i) = (∑i=0..degree h. ?f i) + (∑i=degree h+1 ..< degree u. ?f i)"
unfolding set_rw by (rule sum.union_disjoint, auto)
also have "... = (∑i=0..degree h. ?f i)" using ss0 by simp
finally show ?thesis
by (simp add: atLeast0AtMost atLeast0LessThan)
qed
also have "... = (∑i<degree u. (∑j<degree u. monom (coeff h i) 0 * monom (?B $$ (i, j)) j))"
by (simp add: sum_distrib_left)
also have "... = (∑i<degree u. (∑j<degree u. monom (coeff h i * ?B $$ (i, j)) j))"
by (simp add: mult_monom)
also have "... = (∑j<degree u. (∑i<degree u. monom (coeff h i * ?B $$ (i, j)) j))"
using sum.swap by auto
also have "... = (∑j<degree u. monom (∑i<degree u. (coeff h i * ?B $$ (i, j))) j)"
by (simp add: monom_sum)
finally have ss_rw: "(∑i<degree u. monom (coeff h i) i)
= (∑j<degree u. monom (∑i<degree u. coeff h i * ?B $$ (i, j)) j)" .
have coeff_eq_sum: "∀i. i < degree u ⟶ coeff h i = (∑j<degree u. coeff h j * ?B $$ (j, i))"
using poly_as_sum_eq_monoms[OF ss_rw] by fast
have coeff_eq_sum': "∀i. i < degree u ⟶ H $ i = (∑j<degree u. H $ j * ?B $$ (j, i))"
proof (rule+)
fix i assume i: "i < degree u"
have "H $ i = coeff h i" by (simp add: H deg_le i vec_of_list_coeffs_replicate_nth)
also have "... = (∑j<degree u. coeff h j * ?B $$ (j, i))" using coeff_eq_sum i by blast
also have "... = (∑j<degree u. H $ j * ?B $$ (j, i))"
by (rule sum.cong, auto simp add: H deg_le vec_of_list_coeffs_replicate_nth)
finally show "H $ i = (∑j<degree u. H $ j * ?B $$ (j, i))" .
qed
show "(transpose_mat (?B)) *⇩v H = H"
proof (rule eq_vecI)
fix i
show "dim_vec (transpose_mat ?B *⇩v H) = dim_vec (H)" by auto
assume i: "i < dim_vec (H)"
have "(transpose_mat ?B *⇩v H) $ i = row (transpose_mat ?B) i ∙ H" using i by simp
also have "... = (∑j = 0..<dim_vec H. ?B $$ (j, i) * H $ j)"
proof (rule row_transpose_scalar_prod_as_sum)
show "i < dim_col ?B" using i by simp
show "dim_vec H = dim_row ?B" by simp
qed
also have "... = (∑j<degree u. H $ j * ?B $$ (j, i))" by (rule sum.cong, auto)
also have "... = H $ i" using coeff_eq_sum'[rule_format, symmetric, of i] i by simp
finally show "(transpose_mat ?B *⇩v H) $ i = H $ i" .
qed
qed
qed
end
context
assumes "SORT_CONSTRAINT('a::prime_card)"
begin
lemma exists_s_factor_dvd_h_s:
fixes fi::"'a mod_ring poly"
assumes finite_P: "finite P"
and f_desc_square_free: "f = (∏a∈P. a)"
and P: "P ⊆ {q. irreducible q ∧ monic q}"
and fi_P: "fi ∈ P"
and h: "h ∈ {v. [v^(CARD('a)) = v] (mod f)}"
shows "∃s. fi dvd (h - [:s:])"
proof -
let ?p = "CARD('a)"
have f_dvd_hqh: "f dvd (h^?p - h)" using h unfolding cong_def
using mod_eq_dvd_iff_poly by blast
also have hq_h_rw: "... = prod (λc. h - [:c:]) (UNIV::'a mod_ring set)"
by (rule poly_identity_mod_p)
finally have f_dvd_hc: "f dvd prod (λc. h - [:c:]) (UNIV::'a mod_ring set)" by simp
have "fi dvd f" using f_desc_square_free fi_P
using dvd_prod_eqI finite_P by blast
hence "fi dvd (h^?p - h)" using dvd_trans f_dvd_hqh by auto
also have "... = prod (λc. h - [:c:]) (UNIV::'a mod_ring set)" unfolding hq_h_rw by simp
finally have fi_dvd_prod_hc: "fi dvd prod (λc. h - [:c:]) (UNIV::'a mod_ring set)" .
have irr_fi: "irreducible fi" using fi_P P by blast
have fi_not_unit: "¬ is_unit fi" using irr_fi by (simp add: irreducible⇩dD(1) poly_dvd_1)
show ?thesis using irreducible_dvd_prod[OF _ fi_dvd_prod_hc] irr_fi by auto
qed
corollary exists_unique_s_factor_dvd_h_s:
fixes fi::"'a mod_ring poly"
assumes finite_P: "finite P"
and f_desc_square_free: "f = (∏a∈P. a)"
and P: "P ⊆ {q. irreducible q ∧ monic q}"
and fi_P: "fi ∈ P"
and h: "h ∈ {v. [v^(CARD('a)) = v] (mod f)}"
shows "∃!s. fi dvd (h - [:s:])"
proof -
obtain c where fi_dvd: "fi dvd (h - [:c:])" using assms exists_s_factor_dvd_h_s by blast
have irr_fi: "irreducible fi" using fi_P P by blast
have fi_not_unit: "¬ is_unit fi"
by (simp add: irr_fi irreducible⇩dD(1) poly_dvd_1)
show ?thesis
proof (rule ex1I[of _ c], auto simp add: fi_dvd)
fix c2 assume fi_dvd_hc2: "fi dvd h - [:c2:]"
have *: "fi dvd (h - [:c:]) * (h - [:c2:])" using fi_dvd by auto
hence "fi dvd (h - [:c:]) ∨ fi dvd (h - [:c2:])"
using irr_fi by auto
thus "c2 = c"
using coprime_h_c_poly coprime_not_unit_not_dvd fi_dvd fi_dvd_hc2 fi_not_unit by blast
qed
qed
lemma exists_two_distint: "∃a b::'a mod_ring. a ≠ b"
by (rule exI[of _ 0], rule exI[of _ 1], auto)
lemma coprime_cong_mult_factorization_poly:
fixes f::"'b::{field} poly"
and a b p :: "'c :: {field_gcd} poly"
assumes finite_P: "finite P"
and P: "P ⊆ {q. irreducible q}"
and p: "∀p∈P. [a=b] (mod p)"
and coprime_P: "∀p1 p2. p1 ∈ P ∧ p2 ∈ P ∧ p1 ≠ p2 ⟶ coprime p1 p2"
shows "[a = b] (mod (∏a∈P. a))"
using finite_P P p coprime_P
proof (induct P)
case empty
thus ?case by simp
next
case (insert p P)
have ab_mod_pP: "[a=b] (mod (p * ∏P))"
proof (rule coprime_cong_mult_poly)
show "[a = b] (mod p)" using insert.prems by auto
show "[a = b] (mod ∏P)" using insert.prems insert.hyps by auto
from insert show "Rings.coprime p (∏P)"
by (auto intro: prod_coprime_right)
qed
thus ?case by (simp add: insert.hyps(1) insert.hyps(2))
qed
end
context
assumes "SORT_CONSTRAINT('a::prime_card)"
begin
lemma W_eq_berlekamp_mat:
fixes u::"'a mod_ring poly"
shows "{v. [v^CARD('a) = v] (mod u) ∧ degree v < degree u}
= {h. let H = vec_of_list ((coeffs h) @ replicate (degree u - length (coeffs h)) 0) in
(transpose_mat (berlekamp_mat u)) *⇩v H = H ∧ degree h < degree u}"
using equation_13 by (auto simp add: Let_def)
lemma transpose_minus_1:
assumes "dim_row Q = dim_col Q"
shows "transpose_mat (Q - (1⇩m (dim_row Q))) = (transpose_mat Q - (1⇩m (dim_row Q)))"
using assms
unfolding mat_eq_iff by auto
lemma system_iff:
fixes v::"'b::comm_ring_1 vec"
assumes sq_Q: "dim_row Q = dim_col Q" and v: "dim_row Q = dim_vec v"
shows "(transpose_mat Q *⇩v v = v) ⟷ ((transpose_mat Q - 1⇩m (dim_row Q)) *⇩v v = 0⇩v (dim_vec v))"
proof -
have t1:"transpose_mat Q *⇩v v - v = 0⇩v (dim_vec v) ⟹ (transpose_mat Q - 1⇩m (dim_row Q)) *⇩v v = 0⇩v (dim_vec v)"
by (subst minus_mult_distrib_mat_vec, insert sq_Q[symmetric] v, auto)
have t2:"(transpose_mat Q - 1⇩m (dim_row Q)) *⇩v v = 0⇩v (dim_vec v) ⟹ transpose_mat Q *⇩v v - v = 0⇩v (dim_vec v)"
by (subst (asm) minus_mult_distrib_mat_vec, insert sq_Q[symmetric] v, auto)
have "transpose_mat Q *⇩v v - v = v - v ⟹ transpose_mat Q *⇩v v = v"
proof -
assume a1: "transpose_mat Q *⇩v v - v = v - v"
have f2: "transpose_mat Q *⇩v v ∈ carrier_vec (dim_vec v)"
by (metis dim_mult_mat_vec index_transpose_mat(2) sq_Q v carrier_vec_dim_vec)
then have f3: "0⇩v (dim_vec v) + transpose_mat Q *⇩v v = transpose_mat Q *⇩v v"
by (meson left_zero_vec)
have f4: "0⇩v (dim_vec v) = transpose_mat Q *⇩v v - v"
using a1 by auto
have f5: "- v ∈ carrier_vec (dim_vec v)"
by simp
then have f6: "- v + transpose_mat Q *⇩v v = v - v"
using f2 a1 using comm_add_vec minus_add_uminus_vec by fastforce
have "v - v = - v + v" by auto
then have "transpose_mat Q *⇩v v = transpose_mat Q *⇩v v - v + v"
using f6 f4 f3 f2 by (metis (no_types, lifting) a1 assoc_add_vec comm_add_vec f5 carrier_vec_dim_vec)
then show ?thesis
using a1 by auto
qed
hence "(transpose_mat Q *⇩v v = v) = ((transpose_mat Q *⇩v v) - v = v - v)" by auto
also have "... = ((transpose_mat Q *⇩v v) - v = 0⇩v (dim_vec v))" by auto
also have "... = ((transpose_mat Q - 1⇩m (dim_row Q)) *⇩v v = 0⇩v (dim_vec v))"
using t1 t2 by auto
finally show ?thesis.
qed
lemma system_if_mat_kernel:
assumes sq_Q: "dim_row Q = dim_col Q" and v: "dim_row Q = dim_vec v"
shows "(transpose_mat Q *⇩v v = v) ⟷ v ∈ mat_kernel (transpose_mat (Q - (1⇩m (dim_row Q))))"
proof -
have "(transpose_mat Q *⇩v v = v) = ((transpose_mat Q - 1⇩m (dim_row Q)) *⇩v v = 0⇩v (dim_vec v))"
using assms system_iff by blast
also have "... = (v ∈ mat_kernel (transpose_mat (Q - (1⇩m (dim_row Q)))))"
unfolding mat_kernel_def unfolding transpose_minus_1[OF sq_Q] unfolding v by auto
finally show ?thesis .
qed
lemma degree_u_mod_irreducible⇩d_factor_0:
fixes v and u::"'a mod_ring poly"
defines W: "W ≡ {v. [v ^ CARD('a) = v] (mod u)}"
assumes v: "v ∈ W"
and finite_U: "finite U" and u_U: "u = ∏U" and U_irr_monic: "U ⊆ {q. irreducible q ∧ monic q}"
and fi_U: "fi ∈ U"
shows "degree (v mod fi) = 0"
proof -
have deg_fi: "degree fi > 0"
using U_irr_monic
using fi_U irreducible⇩dD[of fi] by auto
have "fi dvd u"
using u_U U_irr_monic finite_U dvd_prod_eqI fi_U by blast
moreover have "u dvd (v^CARD('a) - v)"
using v unfolding W cong_def
by (simp add: mod_eq_dvd_iff_poly)
ultimately have "fi dvd (v^CARD('a) - v)"
by (rule dvd_trans)
then have fi_dvd_prod_vc: "fi dvd prod (λc. v - [:c:]) (UNIV::'a mod_ring set)"
by (simp add: poly_identity_mod_p)
have irr_fi: "irreducible fi" using fi_U U_irr_monic by blast
have fi_not_unit: "¬ is_unit fi"
using irr_fi
by (auto simp: poly_dvd_1)
have fi_dvd_vc: "∃c. fi dvd v - [:c:]"
using irreducible_dvd_prod[OF _ fi_dvd_prod_vc] irr_fi by auto
from this obtain a where "fi dvd v - [:a:]" by blast
hence "v mod fi = [:a:] mod fi" using mod_eq_dvd_iff_poly by blast
also have "... = [:a:]" by (simp add: deg_fi mod_poly_less)
finally show ?thesis by simp
qed
definition "poly_abelian_monoid
= ⦇carrier = UNIV::'a mod_ring poly set, monoid.mult = ((*)), one = 1, zero = 0, add = (+), module.smult = smult⦈"
interpretation vector_space_poly: vectorspace class_ring poly_abelian_monoid
rewrites [simp]: "𝟬⇘poly_abelian_monoid⇙ = 0"
and [simp]: "𝟭⇘poly_abelian_monoid⇙ = 1"
and [simp]: "(⊕⇘poly_abelian_monoid⇙) = (+)"
and [simp]: "(⊗⇘poly_abelian_monoid⇙) = (*)"
and [simp]: "carrier poly_abelian_monoid = UNIV"
and [simp]: "(⊙⇘poly_abelian_monoid⇙) = smult"
apply unfold_locales
apply (auto simp: poly_abelian_monoid_def class_field_def smult_add_left smult_add_right Units_def)
by (metis add.commute add.right_inverse)
lemma subspace_Berlekamp:
assumes f: "degree f ≠ 0"
shows "subspace (class_ring :: 'a mod_ring ring)
{v. [v^(CARD('a)) = v] (mod f) ∧ (degree v < degree f)} poly_abelian_monoid"
proof -
{ fix v :: "'a mod_ring poly" and w :: "'a mod_ring poly"
assume a1: "v ^ card (UNIV::'a set) mod f = v mod f"
assume "w ^ card (UNIV::'a set) mod f = w mod f"
then have "(v ^ card (UNIV::'a set) + w ^ card (UNIV::'a set)) mod f = (v + w) mod f"
using a1 by (meson mod_add_cong)
then have "(v + w) ^ card (UNIV::'a set) mod f = (v + w) mod f"
by (simp add: add_power_poly_mod_ring)
} note r=this
thus ?thesis using f
by (unfold_locales, auto simp: zero_power mod_smult_left smult_power cong_def degree_add_less)
qed
lemma berlekamp_resulting_mat_closed[simp]:
"berlekamp_resulting_mat u ∈ carrier_mat (degree u) (degree u)"
"dim_row (berlekamp_resulting_mat u) = degree u"
"dim_col (berlekamp_resulting_mat u) = degree u"
proof -
let ?A="(transpose_mat (mat (degree u) (degree u)
(λ(i, j). if i = j then berlekamp_mat u $$ (i, j) - 1 else berlekamp_mat u $$ (i, j))))"
let ?G="(gauss_jordan_single ?A)"
have "?G ∈carrier_mat (degree u) (degree u)"
by (rule gauss_jordan_single(2)[of ?A], auto)
thus
"berlekamp_resulting_mat u ∈ carrier_mat (degree u) (degree u)"
"dim_row (berlekamp_resulting_mat u) = degree u"
"dim_col (berlekamp_resulting_mat u) = degree u"
unfolding berlekamp_resulting_mat_def Let_def by auto
qed
lemma berlekamp_resulting_mat_basis:
"kernel.basis (degree u) (berlekamp_resulting_mat u) (set (find_base_vectors (berlekamp_resulting_mat u)))"
proof (rule find_base_vectors(3))
show "berlekamp_resulting_mat u ∈ carrier_mat (degree u) (degree u)" by simp
let ?A="(transpose_mat (mat (degree u) (degree u)
(λ(i, j). if i = j then berlekamp_mat u $$ (i, j) - 1 else berlekamp_mat u $$ (i, j))))"
have "row_echelon_form (gauss_jordan_single ?A)"
by (rule gauss_jordan_single(3)[of ?A], auto)
thus "row_echelon_form (berlekamp_resulting_mat u)"
unfolding berlekamp_resulting_mat_def Let_def by auto
qed
lemma set_berlekamp_basis_eq: "(set (berlekamp_basis u))
= (Poly ∘ list_of_vec)` (set (find_base_vectors (berlekamp_resulting_mat u)))"
by (auto simp add: image_def o_def berlekamp_basis_def)
lemma berlekamp_resulting_mat_constant:
assumes deg_u: "degree u = 0"
shows "berlekamp_resulting_mat u = 1⇩m 0"
by (unfold mat_eq_iff, auto simp add: deg_u)
context
fixes u::"'a::prime_card mod_ring poly"
begin
lemma set_berlekamp_basis_constant:
assumes deg_u: "degree u = 0"
shows "set (berlekamp_basis u) = {}"
proof -
have one_carrier: "1⇩m 0 ∈ carrier_mat 0 0" by auto
have m: "mat_kernel (1⇩m 0) = {(0⇩v 0) :: 'a mod_ring vec}" unfolding mat_kernel_def by auto
have r: "row_echelon_form (1⇩m 0 :: 'a mod_ring mat)"
unfolding row_echelon_form_def pivot_fun_def Let_def by auto
have "set (find_base_vectors (1⇩m 0)) ⊆ {0⇩v 0 :: 'a mod_ring vec}"
using find_base_vectors(1)[OF r one_carrier] unfolding m .
hence "set (find_base_vectors (1⇩m 0) :: 'a mod_ring vec list) = {}"
using find_base_vectors(2)[OF r one_carrier]
using subset_singletonD by fastforce
thus ?thesis
unfolding set_berlekamp_basis_eq unfolding berlekamp_resulting_mat_constant[OF deg_u] by auto
qed
lemma row_echelon_form_berlekamp_resulting_mat: "row_echelon_form (berlekamp_resulting_mat u)"
by (rule gauss_jordan_single(3), auto simp add: berlekamp_resulting_mat_def Let_def)
lemma mat_kernel_berlekamp_resulting_mat_degree_0:
assumes d: "degree u = 0"
shows "mat_kernel (berlekamp_resulting_mat u) = {0⇩v 0}"
by (auto simp add: mat_kernel_def mult_mat_vec_def d)
lemma in_mat_kernel_berlekamp_resulting_mat:
assumes x: "transpose_mat (berlekamp_mat u) *⇩v x = x"
and x_dim: "x ∈ carrier_vec (degree u)"
shows "x ∈ mat_kernel (berlekamp_resulting_mat u)"
proof -
let ?QI="(mat(dim_row (berlekamp_mat u)) (dim_row (berlekamp_mat u))
(λ(i, j). if i = j then berlekamp_mat u $$ (i, j) - 1 else berlekamp_mat u $$ (i, j)))"
have *: "(transpose_mat (berlekamp_mat u) - 1⇩m (degree u)) = transpose_mat ?QI" by auto
have "(transpose_mat (berlekamp_mat u) - 1⇩m (dim_row (berlekamp_mat u))) *⇩v x = 0⇩v (dim_vec x)"
using system_iff[of "berlekamp_mat u" x] x_dim x by auto
hence "transpose_mat ?QI *⇩v x = 0⇩v (degree u)" using x_dim * by auto
hence "berlekamp_resulting_mat u *⇩v x = 0⇩v (degree u)"
unfolding berlekamp_resulting_mat_def Let_def
using gauss_jordan_single(1)[of "transpose_mat ?QI" "degree u" "degree u" _ x] x_dim by auto
thus ?thesis by (auto simp add: mat_kernel_def x_dim)
qed
private abbreviation "V ≡ kernel.VK (degree u) (berlekamp_resulting_mat u)"
private abbreviation "W ≡ vector_space_poly.vs
{v. [v^(CARD('a)) = v] (mod u) ∧ (degree v < degree u)}"
interpretation V: vectorspace class_ring V
proof -
interpret k: kernel "(degree u)" "(degree u)" "(berlekamp_resulting_mat u)"
by (unfold_locales; auto)
show "vectorspace class_ring V" by intro_locales
qed
lemma linear_Poly_list_of_vec:
shows "(Poly ∘ list_of_vec) ∈ module_hom class_ring V (vector_space_poly.vs {v. [v^(CARD('a)) = v] (mod u)})"
proof (auto simp add: LinearCombinations.module_hom_def Matrix.module_vec_def)
fix m1 m2::" 'a mod_ring vec"
assume m1: "m1 ∈ mat_kernel (berlekamp_resulting_mat u)"
and m2: "m2 ∈ mat_kernel (berlekamp_resulting_mat u)"
have m1_rw: "list_of_vec m1 = map (λn. m1 $ n) [0..<dim_vec m1]"
by (transfer, auto simp add: mk_vec_def)
have m2_rw: "list_of_vec m2 = map (λn. m2 $ n) [0..<dim_vec m2]"
by (transfer, auto simp add: mk_vec_def)
have "m1 ∈ carrier_vec (degree u)" by (rule mat_kernelD(1)[OF _ m1], auto)
moreover have "m2 ∈ carrier_vec (degree u)" by (rule mat_kernelD(1)[OF _ m2], auto)
ultimately have dim_eq: "dim_vec m1 = dim_vec m2" by auto
show "Poly (list_of_vec (m1 + m2)) = Poly (list_of_vec m1) + Poly (list_of_vec m2)"
unfolding poly_eq_iff m1_rw m2_rw plus_vec_def
using dim_eq
by (transfer', auto simp add: mk_vec_def nth_default_def)
next
fix r m assume m: "m ∈ mat_kernel (berlekamp_resulting_mat u)"
show "Poly (list_of_vec (r ⋅⇩v m)) = smult r (Poly (list_of_vec m))"
unfolding poly_eq_iff list_of_vec_rw_map[of m] smult_vec_def
by (transfer', auto simp add: mk_vec_def nth_default_def)
next
fix x assume x: "x ∈ mat_kernel (berlekamp_resulting_mat u)"
show "[Poly (list_of_vec x) ^ CARD('a) = Poly (list_of_vec x)] (mod u)"
proof (cases "degree u = 0")
case True
have "mat_kernel (berlekamp_resulting_mat u) = {0⇩v 0}"
by (rule mat_kernel_berlekamp_resulting_mat_degree_0[OF True])
hence x_0: "x = 0⇩v 0" using x by blast
show ?thesis by (auto simp add: zero_power x_0 cong_def)
next
case False note deg_u = False
show ?thesis
proof -
let ?QI="(mat (degree u) (degree u)
(λ(i, j). if i = j then berlekamp_mat u $$ (i, j) - 1 else berlekamp_mat u $$ (i, j)))"
let ?H="vec_of_list (coeffs (Poly (list_of_vec x)) @ replicate (degree u - length (coeffs (Poly (list_of_vec x)))) 0)"
have x_dim: "dim_vec x = degree u" using x unfolding mat_kernel_def by auto
hence x_carrier[simp]: "x ∈ carrier_vec (degree u)" by (metis carrier_vec_dim_vec)
have x_kernel: "berlekamp_resulting_mat u *⇩v x = 0⇩v (degree u)"
using x unfolding mat_kernel_def by auto
have t_QI_x_0: "(transpose_mat ?QI) *⇩v x = 0⇩v (degree u)"
using gauss_jordan_single(1)[of "(transpose_mat ?QI)" "degree u" "degree u" "gauss_jordan_single (transpose_mat ?QI)" x]
using x_kernel unfolding berlekamp_resulting_mat_def Let_def by auto
have l: "(list_of_vec x) ≠ []"
by (auto simp add: list_of_vec_rw_map vec_of_dim_0[symmetric] deg_u x_dim)
have deg_le: "degree (Poly (list_of_vec x)) < degree u"
using degree_Poly_list_of_vec
using x_carrier deg_u by blast
show "[Poly (list_of_vec x) ^ CARD('a) = Poly (list_of_vec x)] (mod u)"
proof (unfold equation_13[OF deg_le])
have QR_rw: "?QI = berlekamp_mat u - 1⇩m (dim_row (berlekamp_mat u))" by auto
have "dim_row (berlekamp_mat u) = dim_vec ?H"
by (auto, metis le_add_diff_inverse length_list_of_vec length_strip_while_le x_dim)
moreover have "?H ∈ mat_kernel (transpose_mat (berlekamp_mat u - 1⇩m (dim_row (berlekamp_mat u))))"
proof -
have Hx: "?H = x"
proof (unfold vec_eq_iff, auto)
let ?H'="vec_of_list (strip_while ((=) 0) (list_of_vec x)
@ replicate (degree u - length (strip_while ((=) 0) (list_of_vec x))) 0)"
show "length (strip_while ((=) 0) (list_of_vec x))
+ (degree u - length (strip_while ((=) 0) (list_of_vec x))) = dim_vec x"
by (metis le_add_diff_inverse length_list_of_vec length_strip_while_le x_dim)
fix i assume i: "i < dim_vec x"
have "?H $ i = coeff (Poly (list_of_vec x)) i"
proof (rule vec_of_list_coeffs_replicate_nth[OF _ deg_le])
show "i ∈ {..<degree u}" using x_dim i by (auto, linarith)
qed
also have "... = x $ i" by (rule coeff_Poly_list_of_vec_nth'[OF i])
finally show "?H' $ i = x $ i" by auto
qed
have "?H ∈ carrier_vec (degree u)" using deg_le dim_vec_of_list_h Hx by auto
moreover have "transpose_mat (berlekamp_mat u - 1⇩m (degree u)) *⇩v ?H = 0⇩v (degree u)"
using t_QI_x_0 Hx QR_rw by auto
ultimately show ?thesis
by (auto simp add: mat_kernel_def)
qed
ultimately show "transpose_mat (berlekamp_mat u) *⇩v ?H = ?H"
using system_if_mat_kernel[of "berlekamp_mat u" ?H]
by auto
qed
qed
qed
qed
lemma linear_Poly_list_of_vec':
assumes "degree u > 0"
shows "(Poly ∘ list_of_vec) ∈ module_hom R V W"
proof (auto simp add: LinearCombinations.module_hom_def Matrix.module_vec_def)
fix m1 m2::" 'a mod_ring vec"
assume m1: "m1 ∈ mat_kernel (berlekamp_resulting_mat u)"
and m2: "m2 ∈ mat_kernel (berlekamp_resulting_mat u)"
have m1_rw: "list_of_vec m1 = map (λn. m1 $ n) [0..<dim_vec m1]"
by (transfer, auto simp add: mk_vec_def)
have m2_rw: "list_of_vec m2 = map (λn. m2 $ n) [0..<dim_vec m2]"
by (transfer, auto simp add: mk_vec_def)
have "m1 ∈ carrier_vec (degree u)" by (rule mat_kernelD(1)[OF _ m1], auto)
moreover have "m2 ∈ carrier_vec (degree u)" by (rule mat_kernelD(1)[OF _ m2], auto)
ultimately have dim_eq: "dim_vec m1 = dim_vec m2" by auto
show "Poly (list_of_vec (m1 + m2)) = Poly (list_of_vec m1) + Poly (list_of_vec m2)"
unfolding poly_eq_iff m1_rw m2_rw plus_vec_def
using dim_eq
by (transfer', auto simp add: mk_vec_def nth_default_def)
next
fix r m assume m: "m ∈ mat_kernel (berlekamp_resulting_mat u)"
show "Poly (list_of_vec (r ⋅⇩v m)) = smult r (Poly (list_of_vec m))"
unfolding poly_eq_iff list_of_vec_rw_map[of m] smult_vec_def
by (transfer', auto simp add: mk_vec_def nth_default_def)
next
fix x assume x: "x ∈ mat_kernel (berlekamp_resulting_mat u)"
show "[Poly (list_of_vec x) ^ CARD('a) = Poly (list_of_vec x)] (mod u)"
proof (cases "degree u = 0")
case True
have "mat_kernel (berlekamp_resulting_mat u) = {0⇩v 0}"
by (rule mat_kernel_berlekamp_resulting_mat_degree_0[OF True])
hence x_0: "x = 0⇩v 0" using x by blast
show ?thesis by (auto simp add: zero_power x_0 cong_def)
next
case False note deg_u = False
show ?thesis
proof -
let ?QI="(mat (degree u) (degree u)
(λ(i, j). if i = j then berlekamp_mat u $$ (i, j) - 1 else berlekamp_mat u $$ (i, j)))"
let ?H="vec_of_list (coeffs (Poly (list_of_vec x)) @ replicate (degree u - length (coeffs (Poly (list_of_vec x)))) 0)"
have x_dim: "dim_vec x = degree u" using x unfolding mat_kernel_def by auto
hence x_carrier[simp]: "x ∈ carrier_vec (degree u)" by (metis carrier_vec_dim_vec)
have x_kernel: "berlekamp_resulting_mat u *⇩v x = 0⇩v (degree u)"
using x unfolding mat_kernel_def by auto
have t_QI_x_0: "(transpose_mat ?QI) *⇩v x = 0⇩v (degree u)"
using gauss_jordan_single(1)[of "(transpose_mat ?QI)" "degree u" "degree u" "gauss_jordan_single (transpose_mat ?QI)" x]
using x_kernel unfolding berlekamp_resulting_mat_def Let_def by auto
have l: "(list_of_vec x) ≠ []"
by (auto simp add: list_of_vec_rw_map vec_of_dim_0[symmetric] deg_u x_dim)
have deg_le: "degree (Poly (list_of_vec x)) < degree u"
using degree_Poly_list_of_vec
using x_carrier deg_u by blast
show "[Poly (list_of_vec x) ^ CARD('a) = Poly (list_of_vec x)] (mod u)"
proof (unfold equation_13[OF deg_le])
have QR_rw: "?QI = berlekamp_mat u - 1⇩m (dim_row (berlekamp_mat u))" by auto
have "dim_row (berlekamp_mat u) = dim_vec ?H"
by (auto, metis le_add_diff_inverse length_list_of_vec length_strip_while_le x_dim)
moreover have "?H ∈ mat_kernel (transpose_mat (berlekamp_mat u - 1⇩m (dim_row (berlekamp_mat u))))"
proof -
have Hx: "?H = x"
proof (unfold vec_eq_iff, auto)
let ?H'="vec_of_list (strip_while ((=) 0) (list_of_vec x)
@ replicate (degree u - length (strip_while ((=) 0) (list_of_vec x))) 0)"
show "length (strip_while ((=) 0) (list_of_vec x))
+ (degree u - length (strip_while ((=) 0) (list_of_vec x))) = dim_vec x"
by (metis le_add_diff_inverse length_list_of_vec length_strip_while_le x_dim)
fix i assume i: "i < dim_vec x"
have "?H $ i = coeff (Poly (list_of_vec x)) i"
proof (rule vec_of_list_coeffs_replicate_nth[OF _ deg_le])
show "i ∈ {..<degree u}" using x_dim i by (auto, linarith)
qed
also have "... = x $ i" by (rule coeff_Poly_list_of_vec_nth'[OF i])
finally show "?H' $ i = x $ i" by auto
qed
have "?H ∈ carrier_vec (degree u)" using deg_le dim_vec_of_list_h Hx by auto
moreover have "transpose_mat (berlekamp_mat u - 1⇩m (degree u)) *⇩v ?H = 0⇩v (degree u)"
using t_QI_x_0 Hx QR_rw by auto
ultimately show ?thesis
by (auto simp add: mat_kernel_def)
qed
ultimately show "transpose_mat (berlekamp_mat u) *⇩v ?H = ?H"
using system_if_mat_kernel[of "berlekamp_mat u" ?H]
by auto
qed
qed
qed
next
fix x assume x: "x ∈ mat_kernel (berlekamp_resulting_mat u)"
show "degree (Poly (list_of_vec x)) < degree u"
by (rule degree_Poly_list_of_vec, insert assms x, auto simp: mat_kernel_def)
qed
lemma berlekamp_basis_eq_8:
assumes v: "v ∈ set (berlekamp_basis u)"
shows "[v ^ CARD('a) = v] (mod u)"
proof -
{
fix x assume x: "x ∈ set (find_base_vectors (berlekamp_resulting_mat u))"
have "set (find_base_vectors (berlekamp_resulting_mat u)) ⊆ mat_kernel (berlekamp_resulting_mat u)"
proof (rule find_base_vectors(1))
show "row_echelon_form (berlekamp_resulting_mat u)"
by (rule row_echelon_form_berlekamp_resulting_mat)
show "berlekamp_resulting_mat u ∈ carrier_mat (degree u) (degree u)" by simp
qed
hence "x ∈ mat_kernel (berlekamp_resulting_mat u)" using x by auto
hence "[Poly (list_of_vec x) ^ CARD('a) = Poly (list_of_vec x)] (mod u)"
using linear_Poly_list_of_vec
unfolding LinearCombinations.module_hom_def Matrix.module_vec_def by auto
}
thus "[v ^ CARD('a) = v] (mod u)" using v unfolding set_berlekamp_basis_eq by auto
qed
lemma surj_Poly_list_of_vec:
assumes deg_u: "degree u > 0"
shows "(Poly ∘ list_of_vec)` (carrier V) = carrier W"
proof (auto simp add: image_def)
fix xa
assume xa: "xa ∈ mat_kernel (berlekamp_resulting_mat u)"
thus "[Poly (list_of_vec xa) ^ CARD('a) = Poly (list_of_vec xa)] (mod u)"
using linear_Poly_list_of_vec
unfolding LinearCombinations.module_hom_def Matrix.module_vec_def by auto
show "degree (Poly (list_of_vec xa)) < degree u"
proof (rule degree_Poly_list_of_vec[OF _ deg_u])
show "xa ∈ carrier_vec (degree u)" using xa unfolding mat_kernel_def by simp
qed
next
fix x assume x: "[x ^ CARD('a) = x] (mod u)"
and deg_x: "degree x < degree u"
show "∃xa ∈ mat_kernel (berlekamp_resulting_mat u). x = Poly (list_of_vec xa)"
proof (rule bexI[of _ "vec_of_list (coeffs x @ replicate (degree u - length (coeffs x)) 0)"])
let ?X = "vec_of_list (coeffs x @ replicate (degree u - length (coeffs x)) 0)"
show "x = Poly (list_of_vec (vec_of_list (coeffs x @ replicate (degree u - length (coeffs x)) 0)))"
by auto
have X: "?X ∈ carrier_vec (degree u)" unfolding carrier_vec_def
by (auto, metis Suc_leI coeffs_0_eq_Nil deg_x degree_0 le_add_diff_inverse
length_coeffs_degree linordered_semidom_class.add_diff_inverse list.size(3) order.asym)
have t: "transpose_mat (berlekamp_mat u) *⇩v ?X = ?X"
using equation_13[OF deg_x] x by auto
show "vec_of_list (coeffs x @ replicate (degree u - length (coeffs x)) 0)
∈ mat_kernel (berlekamp_resulting_mat u)" by (rule in_mat_kernel_berlekamp_resulting_mat[OF t X])
qed
qed
lemma card_set_berlekamp_basis: "card (set (berlekamp_basis u)) = length (berlekamp_basis u)"
proof -
have b: "berlekamp_resulting_mat u ∈ carrier_mat (degree u) (degree u)" by auto
have "(set (berlekamp_basis u)) = (Poly ∘ list_of_vec) ` set (find_base_vectors (berlekamp_resulting_mat u))"
unfolding set_berlekamp_basis_eq ..
also have " card ... = card (set (find_base_vectors (berlekamp_resulting_mat u)))"
proof (rule card_image, rule subset_inj_on[OF inj_Poly_list_of_vec])
show "set (find_base_vectors (berlekamp_resulting_mat u)) ⊆ carrier_vec (degree u)"
using find_base_vectors(1)[OF row_echelon_form_berlekamp_resulting_mat b]
unfolding carrier_vec_def mat_kernel_def
by auto
qed
also have "... = length (find_base_vectors (berlekamp_resulting_mat u))"
by (rule length_find_base_vectors[symmetric, OF row_echelon_form_berlekamp_resulting_mat b])
finally show ?thesis unfolding berlekamp_basis_def by auto
qed
context
assumes deg_u0[simp]: "degree u > 0"
begin
interpretation Berlekamp_subspace: vectorspace class_ring W
by (rule vector_space_poly.subspace_is_vs[OF subspace_Berlekamp], simp)
lemma linear_map_Poly_list_of_vec': "linear_map class_ring V W (Poly ∘ list_of_vec)"
proof (auto simp add: linear_map_def)
show "vectorspace class_ring V" by intro_locales
show "vectorspace class_ring W" by (rule Berlekamp_subspace.vectorspace_axioms)
show "mod_hom class_ring V W (Poly ∘ list_of_vec)"
proof (rule mod_hom.intro, unfold mod_hom_axioms_def)
show "module class_ring V" by intro_locales
show "module class_ring W" using Berlekamp_subspace.vectorspace_axioms by intro_locales
show "Poly ∘ list_of_vec ∈ module_hom class_ring V W"
by (rule linear_Poly_list_of_vec'[OF deg_u0])
qed
qed
lemma berlekamp_basis_basis:
"Berlekamp_subspace.basis (set (berlekamp_basis u))"
proof (unfold set_berlekamp_basis_eq, rule linear_map.linear_inj_image_is_basis)
show "linear_map class_ring V W (Poly ∘ list_of_vec)"
by (rule linear_map_Poly_list_of_vec')
show "inj_on (Poly ∘ list_of_vec) (carrier V)"
proof (rule subset_inj_on[OF inj_Poly_list_of_vec])
show "carrier V ⊆ carrier_vec (degree u)"
by (auto simp add: mat_kernel_def)
qed
show "(Poly ∘ list_of_vec) ` carrier V = carrier W"
using surj_Poly_list_of_vec[OF deg_u0] by auto
show b: "V.basis (set (find_base_vectors (berlekamp_resulting_mat u)))"
by (rule berlekamp_resulting_mat_basis)
show "V.fin_dim"
proof -
have "finite (set (find_base_vectors (berlekamp_resulting_mat u)))" by auto
moreover have "set (find_base_vectors (berlekamp_resulting_mat u)) ⊆ carrier V"
and "V.gen_set (set (find_base_vectors (berlekamp_resulting_mat u)))"
using b unfolding V.basis_def by auto
ultimately show ?thesis unfolding V.fin_dim_def by auto
qed
qed
lemma finsum_sum:
fixes f::"'a mod_ring poly"
assumes f: "finite B"
and a_Pi: "a ∈ B → carrier R"
and V: "B ⊆ carrier W"
shows "(⨁⇘W⇙v∈B. a v ⊙⇘W⇙ v) = sum (λv. smult (a v) v) B"
using f a_Pi V
proof (induct B)
case empty
thus ?case unfolding Berlekamp_subspace.module.M.finsum_empty by auto
next
case (insert x V)
have hyp: "(⨁⇘W⇙v ∈ V. a v ⊙⇘W⇙ v) = sum (λv. smult (a v) v) V"
proof (rule insert.hyps)
show "a ∈ V → carrier R"
using insert.prems unfolding class_field_def by auto
show "V ⊆ carrier W" using insert.prems by simp
qed
have "(⨁⇘W⇙v∈insert x V. a v ⊙⇘W⇙ v) = (a x ⊙⇘W⇙ x) ⊕⇘W⇙ (⨁⇘W⇙v ∈ V. a v ⊙⇘W⇙ v)"
proof (rule abelian_monoid.finsum_insert)
show "abelian_monoid W" by (unfold_locales)
show "finite V" by fact
show "x ∉ V" by fact
show "(λv. a v ⊙⇘W⇙ v) ∈ V → carrier W"
proof (unfold Pi_def, rule, rule allI, rule impI)
fix v assume v: "v∈V"
show "a v ⊙⇘W⇙ v ∈ carrier W"
proof (rule Berlekamp_subspace.smult_closed)
show "a v ∈ carrier class_ring" using insert.prems v unfolding Pi_def
by (simp add: class_field_def)
show "v ∈ carrier W" using v insert.prems by auto
qed
qed
show "a x ⊙⇘W⇙ x ∈ carrier W"
proof (rule Berlekamp_subspace.smult_closed)
show "a x ∈ carrier class_ring" using insert.prems unfolding Pi_def
by (simp add: class_field_def)
show "x ∈ carrier W" using insert.prems by auto
qed
qed
also have "... = (a x ⊙⇘W⇙ x) + (⨁⇘W⇙v ∈ V. a v ⊙⇘W⇙ v)" by auto
also have "... = (a x ⊙⇘W⇙ x) + sum (λv. smult (a v) v) V" unfolding hyp by simp
also have "... = (smult (a x) x) + sum (λv. smult (a v) v) V" by simp
also have "... = sum (λv. smult (a v) v) (insert x V)"
by (simp add: insert.hyps(1) insert.hyps(2))
finally show ?case .
qed
lemma exists_vector_in_Berlekamp_subspace_dvd:
fixes p_i::"'a mod_ring poly"
assumes finite_P: "finite P"
and f_desc_square_free: "u = (∏a∈P. a)"
and P: "P ⊆ {q. irreducible q ∧ monic q}"
and pi: "p_i ∈ P" and pj: "p_j ∈ P" and pi_pj: "p_i ≠ p_j"
and monic_f: "monic u" and sf_f: "square_free u"
and not_irr_w: "¬ irreducible w"
and w_dvd_f: "w dvd u" and monic_w: "monic w"
and pi_dvd_w: "p_i dvd w" and pj_dvd_w: "p_j dvd w"
shows "∃v. v ∈ {h. [h^(CARD('a)) = h] (mod u) ∧ degree h < degree u}
∧ v mod p_i ≠ v mod p_j
∧ degree (v mod p_i) = 0
∧ degree (v mod p_j) = 0
∧ (∃s. gcd w (v - [:s:]) ≠ w ∧ gcd w (v - [:s:]) ≠ 1)"
proof -
have f_not_0: "u ≠ 0" using monic_f by auto
have irr_pi: "irreducible p_i" using pi P by auto
have irr_pj: "irreducible p_j" using pj P by auto
obtain m and n::nat where P_m: "P = m ` {i. i < n}" and inj_on_m: "inj_on m {i. i < n}"
using finite_imp_nat_seg_image_inj_on[OF finite_P] by blast
hence "n = card P" by (simp add: card_image)
have degree_prod: "degree (prod m {i. i < n}) = degree u"
by (metis P_m f_desc_square_free inj_on_m prod.reindex_cong)
have not_zero: "∀i∈{i. i < n}. m i ≠ 0"
using P_m f_desc_square_free f_not_0 by auto
obtain i where mi: "m i = p_i" and i: "i < n" using P_m pi by blast
obtain j where mj: "m j = p_j" and j: "j < n" using P_m pj by blast
have ij: "i ≠ j" using mi mj pi_pj by auto
obtain s_i and s_j::"'a mod_ring" where si_sj: "s_i ≠ s_j" using exists_two_distint by blast
let ?u="λx. if x = i then [:s_i:] else if x = j then [:s_j:] else [:0:]"
have degree_si: "degree [:s_i:] = 0" by auto
have degree_sj: "degree [:s_j:] = 0" by auto
have "∃!v. degree v < (∑i∈{i. i < n}. degree (m i)) ∧ (∀a∈{i. i < n}. [v = ?u a] (mod m a))"
proof (rule chinese_remainder_unique_poly)
show "∀a∈{i. i < n}. ∀b∈{i. i < n}. a ≠ b ⟶ Rings.coprime (m a) (m b)"
proof (rule+)
fix a b assume "a ∈ {i. i < n}" and "b ∈ {i. i < n}" and "a ≠ b"
thus "Rings.coprime (m a) (m b)"
using coprime_polynomial_factorization[OF P finite_P, simplified] P_m
by (metis image_eqI inj_onD inj_on_m)
qed
show "∀i∈{i. i < n}. m i ≠ 0" by (rule not_zero)
show "0 < degree (prod m {i. i < n})" unfolding degree_prod using deg_u0 by blast
qed
from this obtain v where v: "∀a∈{i. i < n}. [v = ?u a] (mod m a)"
and degree_v: "degree v < (∑i∈{i. i < n}. degree (m i))" by blast
show ?thesis
proof (rule exI[of _ v], auto)
show vp_v_mod: "[v ^ CARD('a) = v] (mod u)"
proof (unfold f_desc_square_free, rule coprime_cong_mult_factorization_poly[OF finite_P])
show "P ⊆ {q. irreducible q}" using P by blast
show "∀p∈P. [v ^ CARD('a) = v] (mod p)"
proof (rule ballI)
fix p assume p: "p ∈ P"
hence irr_p: "irreducible⇩d p" using P by auto
obtain k where mk: "m k = p" and k: "k < n" using P_m p by blast
have "[v = ?u k] (mod p)" using v mk k by auto
moreover have "?u k mod p = ?u k"
apply (rule mod_poly_less) using irreducible⇩dD(1)[OF irr_p] by auto
ultimately obtain s where v_mod_p: "v mod p = [:s:]" unfolding cong_def by force
hence deg_v_p: "degree (v mod p) = 0" by auto
have "v mod p = [:s:]" by (rule v_mod_p)
also have "... = [:s:]^CARD('a)" unfolding poly_const_pow by auto
also have "... = (v mod p) ^ CARD('a)" using v_mod_p by auto
also have "... = (v mod p) ^ CARD('a) mod p" using calculation by auto
also have "... = v^CARD('a) mod p" using power_mod by blast
finally show "[v ^ CARD('a) = v] (mod p)" unfolding cong_def ..
qed
show "∀p1 p2. p1 ∈ P ∧ p2 ∈ P ∧ p1 ≠ p2 ⟶ coprime p1 p2"
using P coprime_polynomial_factorization finite_P by auto
qed
have "[v = ?u i] (mod m i)" using v i by auto
hence v_pi_si_mod: "v mod p_i = [:s_i:] mod p_i" unfolding cong_def mi by auto
also have "... = [:s_i:]" apply (rule mod_poly_less) using irr_pi by auto
finally have v_pi_si: "v mod p_i = [:s_i:]" .
have "[v = ?u j] (mod m j)" using v j by auto
hence v_pj_sj_mod: "v mod p_j = [:s_j:] mod p_j" unfolding cong_def mj using ij by auto
also have "... = [:s_j:]" apply (rule mod_poly_less) using irr_pj by auto
finally have v_pj_sj: "v mod p_j = [:s_j:]" .
show "v mod p_i = v mod p_j ⟹ False" using si_sj v_pi_si v_pj_sj by auto
show "degree (v mod p_i) = 0" unfolding v_pi_si by simp
show "degree (v mod p_j) = 0" unfolding v_pj_sj by simp
show "∃s. gcd w (v - [:s:]) ≠ w ∧ gcd w (v - [:s:]) ≠ 1"
proof (rule exI[of _ s_i], rule conjI)
have pi_dvd_v_si: "p_i dvd v - [:s_i:]" using v_pi_si_mod mod_eq_dvd_iff_poly by blast
have pj_dvd_v_sj: "p_j dvd v - [:s_j:]" using v_pj_sj_mod mod_eq_dvd_iff_poly by blast
have w_eq: "w = prod (λc. gcd w (v - [:c:])) (UNIV::'a mod_ring set)"
proof (rule Berlekamp_gcd_step)
show "[v ^ CARD('a) = v] (mod w)" using vp_v_mod cong_dvd_modulus_poly w_dvd_f by blast
show "square_free w" by (rule square_free_factor[OF w_dvd_f sf_f])
show "monic w" by (rule monic_w)
qed
show "gcd w (v - [:s_i:]) ≠ w"
proof (rule ccontr, simp)
assume gcd_w: "gcd w (v - [:s_i:]) = w"
show False apply (rule ‹v mod p_i = v mod p_j ⟹ False›)
by (metis irreducibleE ‹degree (v mod p_i) = 0› gcd_greatest_iff gcd_w irr_pj is_unit_field_poly mod_eq_dvd_iff_poly mod_poly_less neq0_conv pj_dvd_w v_pi_si)
qed
show "gcd w (v - [:s_i:]) ≠ 1"
by (metis irreducibleE gcd_greatest_iff irr_pi pi_dvd_v_si pi_dvd_w)
qed
show "degree v < degree u"
proof -
have "(∑i | i < n. degree (m i)) = degree (prod m {i. i < n})"
by (rule degree_prod_eq_sum_degree[symmetric, OF not_zero])
thus ?thesis using degree_v unfolding degree_prod by auto
qed
qed
qed
lemma exists_vector_in_Berlekamp_basis_dvd_aux:
assumes basis_V: "Berlekamp_subspace.basis B"
and finite_V: "finite B"
assumes finite_P: "finite P"
and f_desc_square_free: "u = (∏a∈P. a)"
and P: "P ⊆ {q. irreducible q ∧ monic q}"
and pi: "p_i ∈ P" and pj: "p_j ∈ P" and pi_pj: "p_i ≠ p_j"
and monic_f: "monic u" and sf_f: "square_free u"
and not_irr_w: "¬ irreducible w"
and w_dvd_f: "w dvd u" and monic_w: "monic w"
and pi_dvd_w: "p_i dvd w" and pj_dvd_w: "p_j dvd w"
shows "∃v ∈ B. v mod p_i ≠ v mod p_j"
proof (rule ccontr, auto)
have V_in_carrier: "B ⊆ carrier W"
using basis_V unfolding Berlekamp_subspace.basis_def by auto
assume all_eq: "∀v∈B. v mod p_i = v mod p_j"
obtain x where x: "x ∈ {h. [h ^ CARD('a) = h] (mod u) ∧ degree h < degree u}"
and x_pi_pj: "x mod p_i ≠ x mod p_j" and "degree (x mod p_i) = 0" and "degree (x mod p_j) = 0"
"(∃s. gcd w (x - [:s:]) ≠ w ∧ gcd w (x - [:s:]) ≠ 1)"
using exists_vector_in_Berlekamp_subspace_dvd[OF _ _ _ pi pj _ _ _ _ w_dvd_f monic_w pi_dvd_w]
assms by meson
have x_in: "x ∈ carrier W" using x by auto
hence "(∃!a. a ∈ B →⇩E carrier class_ring ∧ Berlekamp_subspace.lincomb a B = x)"
using Berlekamp_subspace.basis_criterion[OF finite_V V_in_carrier] using basis_V
by (simp add: class_field_def)
from this obtain a where a_Pi: "a ∈ B →⇩E carrier class_ring"
and lincomb_x: "Berlekamp_subspace.lincomb a B = x"
by blast
have fs_ss: "(⨁⇘W⇙v∈B. a v ⊙⇘W⇙ v) = sum (λv. smult (a v) v) B"
proof (rule finsum_sum)
show "finite B" by fact
show "a ∈ B → carrier class_ring" using a_Pi by auto
show "B ⊆ carrier W" by (rule V_in_carrier)
qed
have "x mod p_i = Berlekamp_subspace.lincomb a B mod p_i" using lincomb_x by simp
also have " ... = (⨁⇘W⇙v∈B. a v ⊙⇘W⇙ v) mod p_i" unfolding Berlekamp_subspace.lincomb_def ..
also have "... = (sum (λv. smult (a v) v) B) mod p_i" unfolding fs_ss ..
also have "... = sum (λv. smult (a v) v mod p_i) B" using finite_V poly_mod_sum by blast
also have "... = sum (λv. smult (a v) (v mod p_i)) B" by (meson mod_smult_left)
also have "... = sum (λv. smult (a v) (v mod p_j)) B" using all_eq by auto
also have "... = sum (λv. smult (a v) v mod p_j) B" by (metis mod_smult_left)
also have "... = (sum (λv. smult (a v) v) B) mod p_j"
by (metis (mono_tags, lifting) finite_V poly_mod_sum sum.cong)
also have "... = (⨁⇘W⇙v∈B. a v ⊙⇘W⇙ v) mod p_j" unfolding fs_ss ..
also have "... = Berlekamp_subspace.lincomb a B mod p_j"
unfolding Berlekamp_subspace.lincomb_def ..
also have "... = x mod p_j" using lincomb_x by simp
finally have "x mod p_i = x mod p_j" .
thus False using x_pi_pj by contradiction
qed
lemma exists_vector_in_Berlekamp_basis_dvd:
assumes basis_V: "Berlekamp_subspace.basis B"
and finite_V: "finite B"
assumes finite_P: "finite P"
and f_desc_square_free: "u = (∏a∈P. a)"
and P: "P ⊆ {q. irreducible q ∧ monic q}"
and pi: "p_i ∈ P" and pj: "p_j ∈ P" and pi_pj: "p_i ≠ p_j"
and monic_f: "monic u" and sf_f: "square_free u"
and not_irr_w: "¬ irreducible w"
and w_dvd_f: "w dvd u" and monic_w: "monic w"
and pi_dvd_w: "p_i dvd w" and pj_dvd_w: "p_j dvd w"
shows "∃v ∈ B. v mod p_i ≠ v mod p_j
∧ degree (v mod p_i) = 0
∧ degree (v mod p_j) = 0
∧ (∃s. gcd w (v - [:s:]) ≠ w ∧ ¬ coprime w (v - [:s:]))"
proof -
have f_not_0: "u ≠ 0" using monic_f by auto
have irr_pi: "irreducible p_i" using pi P by fast
have irr_pj: "irreducible p_j" using pj P by fast
obtain v where vV: "v ∈ B" and v_pi_pj: "v mod p_i ≠ v mod p_j"
using assms exists_vector_in_Berlekamp_basis_dvd_aux by blast
have v: "v ∈ {v. [v ^ CARD('a) = v] (mod u)}"
using basis_V vV unfolding Berlekamp_subspace.basis_def by auto
have deg_v_pi: "degree (v mod p_i) = 0"
by (rule degree_u_mod_irreducible⇩d_factor_0[OF v finite_P f_desc_square_free P pi])
from this obtain s_i where v_pi_si: "v mod p_i = [:s_i:]" using degree_eq_zeroE by blast
have deg_v_pj: "degree (v mod p_j) = 0"
by (rule degree_u_mod_irreducible⇩d_factor_0[OF v finite_P f_desc_square_free P pj])
from this obtain s_j where v_pj_sj: "v mod p_j = [:s_j:]" using degree_eq_zeroE by blast
have si_sj: "s_i ≠ s_j" using v_pi_si v_pj_sj v_pi_pj by auto
have "(∃s. gcd w (v - [:s:]) ≠ w ∧ ¬ Rings.coprime w (v - [:s:]))"
proof (rule exI[of _ s_i], rule conjI)
have pi_dvd_v_si: "p_i dvd v - [:s_i:]" by (metis mod_eq_dvd_iff_poly mod_mod_trivial v_pi_si)
have pj_dvd_v_sj: "p_j dvd v - [:s_j:]" by (metis mod_eq_dvd_iff_poly mod_mod_trivial v_pj_sj)
have w_eq: "w = prod (λc. gcd w (v - [:c:])) (UNIV::'a mod_ring set)"
proof (rule Berlekamp_gcd_step)
show "[v ^ CARD('a) = v] (mod w)" using v cong_dvd_modulus_poly w_dvd_f by blast
show "square_free w" by (rule square_free_factor[OF w_dvd_f sf_f])
show "monic w" by (rule monic_w)
qed
show "gcd w (v - [:s_i:]) ≠ w"
by (metis irreducibleE deg_v_pi gcd_greatest_iff irr_pj is_unit_field_poly mod_eq_dvd_iff_poly mod_poly_less neq0_conv pj_dvd_w v_pi_pj v_pi_si)
show "¬ Rings.coprime w (v - [:s_i:])"
using irr_pi pi_dvd_v_si pi_dvd_w
by (simp add: irreducible⇩dD(1) not_coprimeI)
qed
thus ?thesis using v_pi_pj vV deg_v_pi deg_v_pj by auto
qed
lemma exists_bijective_linear_map_W_vec:
assumes finite_P: "finite P"
and u_desc_square_free: "u = (∏a∈P. a)"
and P: "P ⊆ {q. irreducible q ∧ monic q}"
shows "∃f. linear_map class_ring W (module_vec TYPE('a mod_ring) (card P)) f
∧ bij_betw f (carrier W) (carrier_vec (card P)::'a mod_ring vec set)"
proof -
let ?B="carrier_vec (card P)::'a mod_ring vec set"
have u_not_0: "u ≠ 0" using deg_u0 degree_0 by force
obtain m and n::nat where P_m: "P = m ` {i. i < n}" and inj_on_m: "inj_on m {i. i < n}"
using finite_imp_nat_seg_image_inj_on[OF finite_P] by blast
hence n: "n = card P" by (simp add: card_image)
have degree_prod: "degree (prod m {i. i < n}) = degree u"
by (metis P_m u_desc_square_free inj_on_m prod.reindex_cong)
have not_zero: "∀i∈{i. i < n}. m i ≠ 0"
using P_m u_desc_square_free u_not_0 by auto
have deg_sum_eq: "(∑i∈{i. i < n}. degree (m i)) = degree u"
by (metis degree_prod degree_prod_eq_sum_degree not_zero)
have coprime_mi_mj:"∀i∈{i. i < n}. ∀j∈{i. i < n}. i ≠ j ⟶ coprime (m i) (m j)"
proof (rule+)
fix i j assume i: "i ∈ {i. i < n}"
and j: "j ∈ {i. i < n}" and ij: "i ≠ j"
show "coprime (m i) (m j)"
proof (rule coprime_polynomial_factorization[OF P finite_P])
show "m i ∈ P" using i P_m by auto
show "m j ∈ P" using j P_m by auto
show "m i ≠ m j" using inj_on_m i ij j unfolding inj_on_def by blast
qed
qed
let ?f = "λv. vec n (λi. coeff (v mod (m i)) 0)"
interpret vec_VS: vectorspace class_ring "(module_vec TYPE('a mod_ring) n)"
by (rule VS_Connect.vec_vs)
interpret linear_map class_ring W "(module_vec TYPE('a mod_ring) n)" ?f
by (intro_locales, unfold mod_hom_axioms_def LinearCombinations.module_hom_def,
auto simp add: vec_eq_iff module_vec_def mod_smult_left poly_mod_add_left)
have "linear_map class_ring W (module_vec TYPE('a mod_ring) n) ?f"
by (intro_locales)
moreover have inj_f: "inj_on ?f (carrier W)"
proof (rule Ke0_imp_inj, auto simp add: mod_hom.ker_def)
show "[0 ^ CARD('a) = 0] (mod u)" by (simp add: cong_def zero_power)
show "vec n (λi. 0) = 𝟬⇘module_vec TYPE('a mod_ring) n⇙" by (auto simp add: module_vec_def)
fix x assume x: "[x ^ CARD('a) = x] (mod u)" and deg_x: "degree x < degree u"
and v: "vec n (λi. coeff (x mod m i) 0) = 𝟬⇘module_vec TYPE('a mod_ring) n⇙"
have cong_0: "∀i∈{i. i < n}. [x = (λi. 0) i] (mod m i)"
proof (rule, unfold cong_def)
fix i assume i: "i ∈ {i. i < n}"
have deg_x_mod_mi: "degree (x mod m i) = 0"
proof (rule degree_u_mod_irreducible⇩d_factor_0[OF _ finite_P u_desc_square_free P])
show "x ∈ {v. [v ^ CARD('a) = v] (mod u)}" using x by auto
show "m i ∈ P" using P_m i by auto
qed
thus "x mod m i = 0 mod m i"
using v
unfolding module_vec_def
by (auto, metis i leading_coeff_neq_0 mem_Collect_eq index_vec index_zero_vec(1))
qed
moreover have deg_x2: "degree x < (∑i∈{i. i < n}. degree (m i))"
using deg_sum_eq deg_x by simp
moreover have "∀i∈{i. i < n}. [0 = (λi. 0) i] (mod m i)"
by (auto simp add: cong_def)
moreover have "degree 0 < (∑i∈{i. i < n}. degree (m i))"
using degree_prod deg_sum_eq deg_u0 by force
moreover have "∃!x. degree x < (∑i∈{i. i < n}. degree (m i))
∧ (∀i∈{i. i < n}. [x = (λi. 0) i] (mod m i))"
proof (rule chinese_remainder_unique_poly[OF not_zero])
show "0 < degree (prod m {i. i < n})"
using deg_u0 degree_prod by linarith
qed (insert coprime_mi_mj, auto)
ultimately show "x = 0" by blast
qed
moreover have "?f ` (carrier W) = ?B"
proof (auto simp add: image_def)
fix xa
show "n = card P" by (auto simp add: n)
next
fix x::"'a mod_ring vec" assume x: "x ∈ carrier_vec (card P)"
have " ∃!v. degree v < (∑i∈{i. i < n}. degree (m i)) ∧ (∀i∈{i. i < n}. [v = (λi. [:x $ i:]) i] (mod m i))"
proof (rule chinese_remainder_unique_poly[OF not_zero])
show "0 < degree (prod m {i. i < n})"
using deg_u0 degree_prod by linarith
qed (insert coprime_mi_mj, auto)
from this obtain v where deg_v: "degree v < (∑i∈{i. i < n}. degree (m i))"
and v_x_cong: "(∀i ∈ {i. i < n}. [v = (λi. [:x $ i:]) i] (mod m i))" by auto
show "∃xa. [xa ^ CARD('a) = xa] (mod u) ∧ degree xa < degree u
∧ x = vec n (λi. coeff (xa mod m i) 0)"
proof (rule exI[of _ v], auto)
show v: "[v ^ CARD('a) = v] (mod u)"
proof (unfold u_desc_square_free, rule coprime_cong_mult_factorization_poly[OF finite_P], auto)
fix y assume y: "y ∈ P" thus "irreducible y" using P by blast
obtain i where i: "i ∈ {i. i < n}" and mi: "y = m i" using P_m y by blast
have "irreducible (m i)" using i P_m P by auto
moreover have "[v = [:x $ i:]] (mod m i)" using v_x_cong i by auto
ultimately have v_mi_eq_xi: "v mod m i = [:x $ i:]"
by (auto simp: cong_def intro!: mod_poly_less)
have xi_pow_xi: "[:x $ i:]^CARD('a) = [:x $ i:]" by (simp add: poly_const_pow)
hence "(v mod m i)^CARD('a) = v mod m i" using v_mi_eq_xi by auto
hence "(v mod m i)^CARD('a) = (v^CARD('a) mod m i)"
by (metis mod_mod_trivial power_mod)
thus "[v ^ CARD('a) = v] (mod y)" unfolding mi cong_def v_mi_eq_xi xi_pow_xi by simp
next
fix p1 p2 assume "p1 ∈ P" and "p2 ∈ P" and "p1 ≠ p2"
then show "Rings.coprime p1 p2"
using coprime_polynomial_factorization[OF P finite_P] by auto
qed
show "degree v < degree u" using deg_v deg_sum_eq degree_prod by presburger
show "x = vec n (λi. coeff (v mod m i) 0)"
proof (unfold vec_eq_iff, rule conjI)
show "dim_vec x = dim_vec (vec n (λi. coeff (v mod m i) 0))" using x n by simp
show "∀i<dim_vec (vec n (λi. coeff (v mod m i) 0)). x $ i = vec n (λi. coeff (v mod m i) 0) $ i"
proof (auto)
fix i assume i: "i < n"
have deg_mi: "irreducible (m i)" using i P_m P by auto
have deg_v_mi: "degree (v mod m i) = 0"
proof (rule degree_u_mod_irreducible⇩d_factor_0[OF _ finite_P u_desc_square_free P])
show "v ∈ {v. [v ^ CARD('a) = v] (mod u)}" using v by fast
show "m i ∈ P" using P_m i by auto
qed
have "v mod m i = [:x $ i:] mod m i" using v_x_cong i unfolding cong_def by auto
also have "... = [:x $ i:]" using deg_mi by (auto intro!: mod_poly_less)
finally show "x $ i = coeff (v mod m i) 0" by simp
qed
qed
qed
qed
ultimately show ?thesis unfolding bij_betw_def n by auto
qed
lemma fin_dim_kernel_berlekamp: "V.fin_dim"
proof -
have "finite (set (find_base_vectors (berlekamp_resulting_mat u)))" by auto
moreover have "set (find_base_vectors (berlekamp_resulting_mat u)) ⊆ carrier V"
and "V.gen_set (set (find_base_vectors (berlekamp_resulting_mat u)))"
using berlekamp_resulting_mat_basis[of u] unfolding V.basis_def by auto
ultimately show ?thesis unfolding V.fin_dim_def by auto
qed
lemma Berlekamp_subspace_fin_dim: "Berlekamp_subspace.fin_dim"
proof (rule linear_map.surj_fin_dim[OF linear_map_Poly_list_of_vec'])
show "(Poly ∘ list_of_vec) ` carrier V = carrier W"
using surj_Poly_list_of_vec[OF deg_u0] by auto
show "V.fin_dim" by (rule fin_dim_kernel_berlekamp)
qed
context
fixes P
assumes finite_P: "finite P"
and u_desc_square_free: "u = (∏a∈P. a)"
and P: "P ⊆ {q. irreducible q ∧ monic q}"
begin
interpretation RV: vec_space "TYPE('a mod_ring)" "card P" .
lemma Berlekamp_subspace_eq_dim_vec: "Berlekamp_subspace.dim = RV.dim"
proof -
obtain f where lm_f: "linear_map class_ring W (module_vec TYPE('a mod_ring) (card P)) f"
and bij_f: "bij_betw f (carrier W) (carrier_vec (card P)::'a mod_ring vec set)"
using exists_bijective_linear_map_W_vec[OF finite_P u_desc_square_free P] by blast
show ?thesis
proof (rule linear_map.dim_eq[OF lm_f Berlekamp_subspace_fin_dim])
show "inj_on f (carrier W)" by (rule bij_betw_imp_inj_on[OF bij_f])
show " f ` carrier W = carrier RV.V" using bij_f unfolding bij_betw_def by auto
qed
qed
lemma Berlekamp_subspace_dim: "Berlekamp_subspace.dim = card P"
using Berlekamp_subspace_eq_dim_vec RV.dim_is_n by simp
corollary card_berlekamp_basis_number_factors: "card (set (berlekamp_basis u)) = card P"
unfolding Berlekamp_subspace_dim[symmetric]
by (rule Berlekamp_subspace.dim_basis[symmetric], auto simp add: berlekamp_basis_basis)
lemma length_berlekamp_basis_numbers_factors: "length (berlekamp_basis u) = card P"
using card_set_berlekamp_basis card_berlekamp_basis_number_factors by auto
end
end
end
end
context
assumes "SORT_CONSTRAINT('a :: prime_card)"
begin
context
fixes f :: "'a mod_ring poly" and n
assumes sf: "square_free f"
and n: "n = length (berlekamp_basis f)"
and monic_f: "monic f"
begin
lemma berlekamp_basis_length_factorization: assumes f: "f = prod_list us"
and d: "⋀ u. u ∈ set us ⟹ degree u > 0"
shows "length us ≤ n"
proof (cases "degree f = 0")
case True
have "us = []"
proof (rule ccontr)
assume "us ≠ []"
from this obtain u where u: "u ∈ set us" by fastforce
hence deg_u: "degree u > 0" using d by auto
have "degree f = degree (prod_list us)" unfolding f ..
also have "... = sum_list (map degree us)"
proof (rule degree_prod_list_eq)
fix p assume p: "p ∈ set us"
show "p ≠ 0" using d[OF p] degree_0 by auto
qed
also have " ... ≥ degree u" by (simp add: member_le_sum_list u)
finally have "degree f > 0" using deg_u by auto
thus False using True by auto
qed
thus ?thesis by simp
next
case False
hence f_not_0: "f ≠ 0" using degree_0 by fastforce
obtain P where fin_P: "finite P" and f_P: "f = ∏P" and P: "P ⊆ {p. irreducible p ∧ monic p}"
using monic_square_free_irreducible_factorization[OF monic_f sf] by auto
have n_card_P: "n = card P"
using P False f_P fin_P length_berlekamp_basis_numbers_factors n by blast
have distinct_us: "distinct us" using d f sf square_free_prod_list_distinct by blast
let ?us'="(map normalize us)"
have distinct_us': "distinct ?us'"
proof (auto simp add: distinct_map)
show "distinct us" by (rule distinct_us)
show "inj_on normalize (set us)"
proof (auto simp add: inj_on_def, rule ccontr)
fix x y assume x: "x ∈ set us" and y: "y ∈ set us" and n: "normalize x = normalize y"
and x_not_y: "x ≠ y"
from normalize_eq_imp_smult[OF n]
obtain c where c0: "c ≠ 0" and y_smult: "y = smult c x" by blast
have sf_xy: "square_free (x*y)"
proof (rule square_free_factor[OF _ sf])
have "x*y = prod_list [x,y]" by simp
also have "... dvd prod_list us"
by (rule prod_list_dvd_prod_list_subset, auto simp add: x y x_not_y distinct_us)
also have "... = f" unfolding f ..
finally show "x * y dvd f" .
qed
have "x * y = smult c (x*x)" using y_smult mult_smult_right by auto
hence sf_smult: "square_free (smult c (x*x))" using sf_xy by auto
have "x*x dvd (smult c (x*x))" by (simp add: dvd_smult)
hence "¬ square_free (smult c (x*x))"
by (metis d square_free_def x)
thus "False" using sf_smult by contradiction
qed
qed
have length_us_us': "length us = length ?us'" by simp
have f_us': "f = prod_list ?us'"
proof -
have "f = normalize f" using monic_f f_not_0 by (simp add: normalize_monic)
also have "... = prod_list ?us'" by (unfold f, rule prod_list_normalize[of us])
finally show ?thesis .
qed
have "∃Q. prod_list Q = prod_list ?us' ∧ length ?us' ≤ length Q
∧ (∀u. u ∈ set Q ⟶ irreducible u ∧ monic u)"
proof (rule exists_factorization_prod_list)
show "degree (prod_list ?us') > 0" using False f_us' by auto
show "square_free (prod_list ?us')" using f_us' sf by auto
fix u assume u: "u ∈ set ?us'"
have u_not0: "u ≠ 0" using d u degree_0 by fastforce
have "degree u > 0" using d u by auto
moreover have "monic u" using u monic_normalize[OF u_not0] by auto
ultimately show "degree u > 0 ∧ monic u" by simp
qed
from this obtain Q
where Q_us': "prod_list Q = prod_list ?us'"
and length_us'_Q: "length ?us' ≤ length Q"
and Q: "(∀u. u ∈ set Q ⟶ irreducible u ∧ monic u)"
by blast
have distinct_Q: "distinct Q"
proof (rule square_free_prod_list_distinct)
show "square_free (prod_list Q)" using Q_us' f_us' sf by auto
show "⋀u. u ∈ set Q ⟹ degree u > 0" using Q irreducible_degree_field by auto
qed
have set_Q_P: "set Q = P"
proof (rule monic_factorization_uniqueness)
show "∏(set Q) = ∏P" using Q_us'
by (metis distinct_Q f_P f_us' list.map_ident prod.distinct_set_conv_list)
qed (insert P Q fin_P, auto)
hence "length Q = card P" using distinct_Q distinct_card by fastforce
have "length us = length ?us'" by (rule length_us_us')
also have "... ≤ length Q" using length_us'_Q by auto
also have "... = card (set Q)" using distinct_card[OF distinct_Q] by simp
also have "... = card P" using set_Q_P by simp
finally show ?thesis using n_card_P by simp
qed
lemma berlekamp_basis_irreducible: assumes f: "f = prod_list us"
and n_us: "length us = n"
and us: "⋀ u. u ∈ set us ⟹ degree u > 0"
and u: "u ∈ set us"
shows "irreducible u"
proof (fold irreducible_connect_field, intro irreducible⇩dI[OF us[OF u]])
fix q r :: "'a mod_ring poly"
assume dq: "degree q > 0" and qu: "degree q < degree u" and dr: "degree r > 0" and uqr: "u = q * r"
with us[OF u] have q: "q ≠ 0" and r: "r ≠ 0" by auto
from split_list[OF u] obtain xs ys where id: "us = xs @ u # ys" by auto
let ?us = "xs @ q # r # ys"
have f: "f = prod_list ?us" unfolding f id uqr by simp
{
fix x
assume "x ∈ set ?us"
with us[unfolded id] dr dq have "degree x > 0" by auto
}
from berlekamp_basis_length_factorization[OF f this]
have "length ?us ≤ n" by simp
also have "… = length us" unfolding n_us by simp
also have "… < length ?us" unfolding id by simp
finally show False by simp
qed
end
lemma not_irreducible_factor_yields_prime_factors:
assumes uf: "u dvd (f :: 'b :: {field_gcd} poly)" and fin: "finite P"
and fP: "f = ∏P" and P: "P ⊆ {q. irreducible q ∧ monic q}"
and u: "degree u > 0" "¬ irreducible u"
shows "∃ pi pj. pi ∈ P ∧ pj ∈ P ∧ pi ≠ pj ∧ pi dvd u ∧ pj dvd u"
proof -
from finite_distinct_list[OF fin] obtain ps where Pps: "P = set ps" and dist: "distinct ps" by auto
have fP: "f = prod_list ps" unfolding fP Pps using dist
by (simp add: prod.distinct_set_conv_list)
note P = P[unfolded Pps]
have "set ps ⊆ P" unfolding Pps by auto
from uf[unfolded fP] P dist this
show ?thesis
proof (induct ps)
case Nil
with u show ?case using divides_degree[of u 1] by auto
next
case (Cons p ps)
from Cons(3) have ps: "set ps ⊆ {q. irreducible q ∧ monic q}" by auto
from Cons(2) have dvd: "u dvd p * prod_list ps" by simp
obtain k where gcd: "u = gcd p u * k" by (meson dvd_def gcd_dvd2)
from Cons(3) have *: "monic p" "irreducible p" "p ≠ 0" by auto
from monic_irreducible_gcd[OF *(1), of u] *(2)
have "gcd p u = 1 ∨ gcd p u = p" by auto
thus ?case
proof
assume "gcd p u = 1"
then have "Rings.coprime p u"
by (rule gcd_eq_1_imp_coprime)
with dvd have "u dvd prod_list ps"
using coprime_dvd_mult_right_iff coprime_imp_coprime by blast
from Cons(1)[OF this ps] Cons(4-5) show ?thesis by auto
next
assume "gcd p u = p"
with gcd have upk: "u = p * k" by auto
hence p: "p dvd u" by auto
from dvd[unfolded upk] *(3) have kps: "k dvd prod_list ps" by auto
from dvd u * have dk: "degree k > 0"
by (metis gr0I irreducible_mult_unit_right is_unit_iff_degree mult_zero_right upk)
from ps kps have "∃ q ∈ set ps. q dvd k"
proof (induct ps)
case Nil
with dk show ?case using divides_degree[of k 1] by auto
next
case (Cons p ps)
from Cons(3) have dvd: "k dvd p * prod_list ps" by simp
obtain l where gcd: "k = gcd p k * l" by (meson dvd_def gcd_dvd2)
from Cons(2) have *: "monic p" "irreducible p" "p ≠ 0" by auto
from monic_irreducible_gcd[OF *(1), of k] *(2)
have "gcd p k = 1 ∨ gcd p k = p" by auto
thus ?case
proof
assume "gcd p k = 1"
with dvd have "k dvd prod_list ps"
by (metis dvd_triv_left gcd_greatest_mult mult.left_neutral)
from Cons(1)[OF _ this] Cons(2) show ?thesis by auto
next
assume "gcd p k = p"
with gcd have upk: "k = p * l" by auto
hence p: "p dvd k" by auto
thus ?thesis by auto
qed
qed
then obtain q where q: "q ∈ set ps" and dvd: "q dvd k" by auto
from dvd upk have qu: "q dvd u" by auto
from Cons(4) q have "p ≠ q" by auto
thus ?thesis using q p qu Cons(5) by auto
qed
qed
qed
lemma berlekamp_factorization_main:
fixes f::"'a mod_ring poly"
assumes sf_f: "square_free f"
and vs: "vs = vs1 @ vs2"
and vsf: "vs = berlekamp_basis f"
and n_bb: "n = length (berlekamp_basis f)"
and n: "n = length us1 + n2"
and us: "us = us1 @ berlekamp_factorization_main d divs vs2 n2"
and us1: "⋀ u. u ∈ set us1 ⟹ monic u ∧ irreducible u"
and divs: "⋀ d. d ∈ set divs ⟹ monic d ∧ degree d > 0"
and vs1: "⋀ u v i. v ∈ set vs1 ⟹ u ∈ set us1 ∪ set divs
⟹ i < CARD('a) ⟹ gcd u (v - [:of_nat i:]) ∈ {1,u}"
and f: "f = prod_list (us1 @ divs)"
and deg_f: "degree f > 0"
and d: "⋀ g. g dvd f ⟹ degree g = d ⟹ irreducible g"
shows "f = prod_list us ∧ (∀ u ∈ set us. monic u ∧ irreducible u)"
proof -
have mon_f: "monic f" unfolding f
by (rule monic_prod_list, insert divs us1, auto)
from monic_square_free_irreducible_factorization[OF mon_f sf_f] obtain P where
P: "finite P" "f = ∏ P" "P ⊆ {q. irreducible q ∧ monic q}" by auto
hence f0: "f ≠ 0" by auto
show ?thesis
using vs n us divs f us1 vs1
proof (induct vs2 arbitrary: divs n2 us1 vs1)
case (Cons v vs2)
show ?case
proof (cases "v = 1")
case False
from Cons(2) vsf have v: "v ∈ set (berlekamp_basis f)" by auto
from berlekamp_basis_eq_8[OF this] have vf: "[v ^ CARD('a) = v] (mod f)" .
let ?gcd = "λ u i. gcd u (v - [:of_int i:])"
let ?gcdn = "λ u i. gcd u (v - [:of_nat i:])"
let ?map = "λ u. (map (λ i. ?gcd u i) [0 ..< CARD('a)])"
define udivs where "udivs ≡ λ u. filter (λ w. w ≠ 1) (?map u)"
{
obtain xs where xs: "[0..<CARD('a)] = xs" by auto
have "udivs = (λ u. [w. i ← [0 ..< CARD('a)], w ← [?gcd u i], w ≠ 1])"
unfolding udivs_def xs
by (intro ext, auto simp: o_def, induct xs, auto)
} note udivs_def' = this
define facts where "facts ≡ [ w . u ← divs, w ← udivs u]"
{
fix u
assume u: "u ∈ set divs"
then obtain bef aft where divs: "divs = bef @ u # aft" by (meson split_list)
from Cons(5)[OF u] have mon_u: "monic u" by simp
have uf: "u dvd f" unfolding Cons(6) divs by auto
from vf uf have vu: "[v ^ CARD('a) = v] (mod u)" by (rule cong_dvd_modulus_poly)
from square_free_factor[OF uf sf_f] have sf_u: "square_free u" .
let ?g = "?gcd u"
from mon_u have u0: "u ≠ 0" by auto
have "u = (∏c∈UNIV. gcd u (v - [:c:]))"
using Berlekamp_gcd_step[OF vu mon_u sf_u] .
also have "… = (∏i ∈ {0..< int CARD('a)}. ?g i)"
by (rule sym, rule prod.reindex_cong[OF to_int_mod_ring_hom.inj_f range_to_int_mod_ring[symmetric]],
simp add: of_int_of_int_mod_ring)
finally have u_prod: "u = (∏i ∈ {0..< int CARD('a)}. ?g i)" .
let ?S = "{0..<int CARD('a)} - {i. ?g i = 1}"
{
fix i
assume "i ∈ ?S"
hence "?g i ≠ 1" by auto
moreover have mgi: "monic (?g i)" by (rule poly_gcd_monic, insert u0, auto)
ultimately have "degree (?g i) > 0"
using monic_degree_0 by blast
note this mgi
} note gS = this
have int_set: "int ` set [0..<CARD('a)] = {0 ..< int CARD('a)}"
by (simp add: image_int_atLeastLessThan)
have inj: "inj_on ?g ?S" unfolding inj_on_def
proof (intro ballI impI)
fix i j
assume i: "i ∈ ?S" and j: "j ∈ ?S" and gij: "?g i = ?g j"
show "i = j"
proof (rule ccontr)
define S where "S = {0..<int CARD('a)} - {i,j}"
have id: "{0..<int CARD('a)} = (insert i (insert j S))" and S: "i ∉ S" "j ∉ S" "finite S"
using i j unfolding S_def by auto
assume ij: "i ≠ j"
have "u = (∏i ∈ {0..< int CARD('a)}. ?g i)" by fact
also have "… = ?g i * ?g j * (∏i ∈ S. ?g i)"
unfolding id using S ij by auto
also have "… = ?g i * ?g i * (∏i ∈ S. ?g i)" unfolding gij by simp
finally have dvd: "?g i * ?g i dvd u" unfolding dvd_def by auto
with sf_u[unfolded square_free_def, THEN conjunct2, rule_format, OF gS(1)[OF i]]
show False by simp
qed
qed
have "u = (∏i ∈ {0..< int CARD('a)}. ?g i)" by fact
also have "… = (∏i ∈ ?S. ?g i)"
by (rule sym, rule prod.setdiff_irrelevant, auto)
also have "… = ∏ (set (udivs u))" unfolding udivs_def set_filter set_map
by (rule sym, rule prod.reindex_cong[of ?g, OF inj _ refl], auto simp: int_set[symmetric])
finally have u_udivs: "u = ∏(set (udivs u))" .
{
fix w
assume mem: "w ∈ set (udivs u)"
then obtain i where w: "w = ?g i" and i: "i ∈ ?S"
unfolding udivs_def set_filter set_map int_set by auto
have wu: "w dvd u" by (simp add: w)
let ?v = "λ j. v - [:of_nat j:]"
define j where "j = nat i"
from i have j: "of_int i = (of_nat j :: 'a mod_ring)" "j < CARD('a)" unfolding j_def by auto
from gS[OF i, folded w] have *: "degree w > 0" "monic w" "w ≠ 0" by auto
from w have "w dvd ?v j" using j by simp
hence gcdj: "?gcdn w j = w" by (metis gcd.commute gcd_left_idem j(1) w)
{
fix j'
assume j': "j' < CARD('a)"
have "?gcdn w j' ∈ {1,w}"
proof (rule ccontr)
assume not: "?gcdn w j' ∉ {1,w}"
with gcdj have neq: "int j' ≠ int j" by auto
let ?h = "?gcdn w j'"
from *(3) not have deg: "degree ?h > 0"
using monic_degree_0 poly_gcd_monic by auto
have hw: "?h dvd w" by auto
have "?h dvd ?gcdn u j'" using wu using dvd_trans by auto
also have "?gcdn u j' = ?g j'" by simp
finally have hj': "?h dvd ?g j'" by auto
from divides_degree[OF this] deg u0 have degj': "degree (?g j') > 0" by auto
hence j'1: "?g j' ≠ 1" by auto
with j' have mem': "?g j' ∈ set (udivs u)" unfolding udivs_def by auto
from degj' j' have j'S: "int j' ∈ ?S" by auto
from i j have jS: "int j ∈ ?S" by auto
from inj_on_contraD[OF inj neq j'S jS]
have neq: "w ≠ ?g j'" using w j by auto
have cop: "¬ coprime w (?g j')" using hj' hw deg
by (metis coprime_not_unit_not_dvd poly_dvd_1 Nat.neq0_conv)
obtain w' where w': "?g j' = w'" by auto
from u_udivs sf_u have "square_free (∏(set (udivs u)))" by simp
from square_free_prodD[OF this finite_set mem mem'] cop neq
show False by simp
qed
}
from gS[OF i, folded w] i this
have "degree w > 0" "monic w" "⋀ j. j < CARD('a) ⟹ ?gcdn w j ∈ {1,w}" by auto
} note udivs = this
let ?is = "filter (λ i. ?g i ≠ 1) (map int [0 ..< CARD('a)])"
have id: "udivs u = map ?g ?is"
unfolding udivs_def filter_map o_def ..
have dist: "distinct (udivs u)" unfolding id distinct_map
proof (rule conjI[OF distinct_filter], unfold distinct_map)
have "?S = set ?is" unfolding int_set[symmetric] by auto
thus "inj_on ?g (set ?is)" using inj by auto
qed (auto simp: inj_on_def)
from u_udivs prod.distinct_set_conv_list[OF dist, of id]
have "prod_list (udivs u) = u" by auto
note udivs this dist
} note udivs = this
have facts: "facts = concat (map udivs divs)"
unfolding facts_def by auto
obtain lin nonlin where part: "List.partition (λ q. degree q = d) facts = (lin,nonlin)"
by force
from Cons(6) have "f = prod_list us1 * prod_list divs" by auto
also have "prod_list divs = prod_list facts" unfolding facts using udivs(4)
by (induct divs, auto)
finally have f: "f = prod_list us1 * prod_list facts" .
note facts' = facts
{
fix u
assume u: "u ∈ set facts"
from u[unfolded facts] obtain u' where u': "u' ∈ set divs" and u: "u ∈ set (udivs u')" by auto
from u' udivs(1-2)[OF u' u] prod_list_dvd[OF u, unfolded udivs(4)[OF u']]
have "degree u > 0" "monic u" "∃ u' ∈ set divs. u dvd u'" by auto
} note facts = this
have not1: "(v = 1) = False" using False by auto
have "us = us1 @ (if length divs = n2 then divs
else let (lin, nonlin) = List.partition (λq. degree q = d) facts
in lin @ berlekamp_factorization_main d nonlin vs2 (n2 - length lin))"
unfolding Cons(4) facts_def udivs_def' berlekamp_factorization_main.simps Let_def not1 if_False
by (rule arg_cong[where f = "λ x. us1 @ x"], rule if_cong, simp_all)
hence res: "us = us1 @ (if length divs = n2 then divs else
lin @ berlekamp_factorization_main d nonlin vs2 (n2 - length lin))"
unfolding part by auto
show ?thesis
proof (cases "length divs = n2")
case False
with res have us: "us = (us1 @ lin) @ berlekamp_factorization_main d nonlin vs2 (n2 - length lin)"
by auto
from Cons(2) have vs: "vs = (vs1 @ [v]) @ vs2" by auto
have f: "f = prod_list ((us1 @ lin) @ nonlin)"
unfolding f using prod_list_partition[OF part] by simp
{
fix u
assume "u ∈ set ((us1 @ lin) @ nonlin)"
with part have "u ∈ set facts ∪ set us1" by auto
with facts Cons(7) have "degree u > 0" by (auto simp: irreducible_degree_field)
} note deg = this
from berlekamp_basis_length_factorization[OF sf_f n_bb mon_f f deg, unfolded Cons(3)]
have "n2 ≥ length lin" by auto
hence n: "n = length (us1 @ lin) + (n2 - length lin)"
unfolding Cons(3) by auto
show ?thesis
proof (rule Cons(1)[OF vs n us _ f])
fix u
assume "u ∈ set nonlin"
with part have "u ∈ set facts" by auto
from facts[OF this] show "monic u ∧ degree u > 0" by auto
next
fix u
assume u: "u ∈ set (us1 @ lin)"
{
assume *: "¬ (monic u ∧ irreducible⇩d u)"
with Cons(7) u have "u ∈ set lin" by auto
with part have uf: "u ∈ set facts" and deg: "degree u = d" by auto
from facts[OF uf] obtain u' where "u' ∈ set divs" and uu': "u dvd u'" by auto
from this(1) have "u' dvd f" unfolding Cons(6) using prod_list_dvd[of u'] by auto
with uu' have "u dvd f" by (rule dvd_trans)
from facts[OF uf] d[OF this deg] * have False by auto
}
thus "monic u ∧ irreducible u" by auto
next
fix w u i
assume w: "w ∈ set (vs1 @ [v])"
and u: "u ∈ set (us1 @ lin) ∪ set nonlin"
and i: "i < CARD('a)"
from u part have u: "u ∈ set us1 ∪ set facts" by auto
show "gcd u (w - [:of_nat i:]) ∈ {1, u}"
proof (cases "u ∈ set us1")
case True
from Cons(7)[OF this] have "monic u" "irreducible u" by auto
thus ?thesis by (rule monic_irreducible_gcd)
next
case False
with u have u: "u ∈ set facts" by auto
show ?thesis
proof (cases "w = v")
case True
from u[unfolded facts'] obtain u' where u: "u ∈ set (udivs u')"
and u': "u' ∈ set divs" by auto
from udivs(3)[OF u' u i] show ?thesis unfolding True .
next
case False
with w have w: "w ∈ set vs1" by auto
from u obtain u' where u': "u' ∈ set divs" and dvd: "u dvd u'"
using facts(3)[of u] dvd_refl[of u] by blast
from w have "w ∈ set vs1 ∨ w = v" by auto
from facts(1-2)[OF u] have u: "monic u" by auto
from Cons(8)[OF w _ i] u'
have "gcd u' (w - [:of_nat i:]) ∈ {1, u'}" by auto
with dvd u show ?thesis by (rule monic_gcd_dvd)
qed
qed
qed
next
case True
with res have us: "us = us1 @ divs" by auto
from Cons(3) True have n: "n = length us" unfolding us by auto
show ?thesis unfolding us[symmetric]
proof (intro conjI ballI)
show f: "f = prod_list us" unfolding us using Cons(6) by simp
{
fix u
assume "u ∈ set us"
hence "degree u > 0" using Cons(5) Cons(7)[unfolded irreducible⇩d_def]
unfolding us by (auto simp: irreducible_degree_field)
} note deg = this
fix u
assume u: "u ∈ set us"
thus "monic u" unfolding us using Cons(5) Cons(7) by auto
show "irreducible u"
by (rule berlekamp_basis_irreducible[OF sf_f n_bb mon_f f n[symmetric] deg u])
qed
qed
next
case True
with Cons(4) have us: "us = us1 @ berlekamp_factorization_main d divs vs2 n2" by simp
from Cons(2) True have vs: "vs = (vs1 @ [1]) @ vs2" by auto
show ?thesis
proof (rule Cons(1)[OF vs Cons(3) us Cons(5-7)], goal_cases)
case (3 v u i)
show ?case
proof (cases "v = 1")
case False
with 3 Cons(8)[of v u i] show ?thesis by auto
next
case True
hence deg: "degree (v - [: of_nat i :]) = 0"
by (metis (no_types, hide_lams) degree_pCons_0 diff_pCons diff_zero pCons_one)
from 3(2) Cons(5,7)[of u] have "monic u" by auto
from gcd_monic_constant[OF this deg] show ?thesis .
qed
qed
qed
next
case Nil
with vsf have vs1: "vs1 = berlekamp_basis f" by auto
from Nil(3) have us: "us = us1 @ divs" by auto
from Nil(4,6) have md: "⋀ u. u ∈ set us ⟹ monic u ∧ degree u > 0"
unfolding us by (auto simp: irreducible_degree_field)
from Nil(7)[unfolded vs1] us
have no_further_splitting_possible:
"⋀ u v i. v ∈ set (berlekamp_basis f) ⟹ u ∈ set us
⟹ i < CARD('a) ⟹ gcd u (v - [:of_nat i:]) ∈ {1, u}" by auto
from Nil(5) us have prod: "f = prod_list us" by simp
show ?case
proof (intro conjI ballI)
fix u
assume u: "u ∈ set us"
from md[OF this] have mon_u: "monic u" and deg_u: "degree u > 0" by auto
from prod u have uf: "u dvd f" by (simp add: prod_list_dvd)
from monic_square_free_irreducible_factorization[OF mon_f sf_f] obtain P where
P: "finite P" "f = ∏P" "P ⊆ {q. irreducible q ∧ monic q}" by auto
show "irreducible u"
proof (rule ccontr)
assume irr_u: "¬ irreducible u"
from not_irreducible_factor_yields_prime_factors[OF uf P deg_u this]
obtain pi pj where pij: "pi ∈ P" "pj ∈ P" "pi ≠ pj" "pi dvd u" "pj dvd u" by blast
from exists_vector_in_Berlekamp_basis_dvd[OF
deg_f berlekamp_basis_basis[OF deg_f, folded vs1] finite_set
P pij(1-3) mon_f sf_f irr_u uf mon_u pij(4-5), unfolded vs1]
obtain v s where v: "v ∈ set (berlekamp_basis f)"
and gcd: "gcd u (v - [:s:]) ∉ {1,u}" using is_unit_gcd by auto
from surj_of_nat_mod_ring[of s] obtain i where i: "i < CARD('a)" and s: "s = of_nat i" by auto
from no_further_splitting_possible[OF v u i] gcd[unfolded s]
show False by auto
qed
qed (insert prod md, auto)
qed
qed
lemma berlekamp_monic_factorization:
fixes f::"'a mod_ring poly"
assumes sf_f: "square_free f"
and us: "berlekamp_monic_factorization d f = us"
and d: "⋀ g. g dvd f ⟹ degree g = d ⟹ irreducible g"
and deg: "degree f > 0"
and mon: "monic f"
shows "f = prod_list us ∧ (∀ u ∈ set us. monic u ∧ irreducible u)"
proof -
from us[unfolded berlekamp_monic_factorization_def Let_def] deg
have us: "us = [] @ berlekamp_factorization_main d [f] (berlekamp_basis f) (length (berlekamp_basis f))"
by (auto)
have id: "berlekamp_basis f = [] @ berlekamp_basis f"
"length (berlekamp_basis f) = length [] + length (berlekamp_basis f)"
"f = prod_list ([] @ [f])"
by auto
show "f = prod_list us ∧ (∀ u ∈ set us. monic u ∧ irreducible u)"
by (rule berlekamp_factorization_main[OF sf_f id(1) refl refl id(2) us _ _ _ id(3)],
insert mon deg d, auto)
qed
end
end
Theory Distinct_Degree_Factorization
section ‹Distinct Degree Factorization›
theory Distinct_Degree_Factorization
imports
Finite_Field
Polynomial_Factorization.Square_Free_Factorization
Berlekamp_Type_Based
begin
definition factors_of_same_degree :: "nat ⇒ 'a :: field poly ⇒ bool" where
"factors_of_same_degree i f = (i ≠ 0 ∧ degree f ≠ 0 ∧ monic f ∧ (∀ g. irreducible g ⟶ g dvd f ⟶ degree g = i))"
lemma factors_of_same_degreeD: assumes "factors_of_same_degree i f"
shows "i ≠ 0" "degree f ≠ 0" "monic f" "g dvd f ⟹ irreducible g = (degree g = i)"
proof -
note * = assms[unfolded factors_of_same_degree_def]
show i: "i ≠ 0" and f: "degree f ≠ 0" "monic f" using * by auto
assume gf: "g dvd f"
with * have "irreducible g ⟹ degree g = i" by auto
moreover
{
assume **: "degree g = i" "¬ irreducible g"
with irreducible⇩d_factor[of g] i obtain h1 h2 where irr: "irreducible h1" and gh: "g = h1 * h2"
and deg_h2: "degree h2 < degree g" by auto
from ** i have g0: "g ≠ 0" by auto
from gf gh g0 have "h1 dvd f" using dvd_mult_left by blast
from * f this irr have deg_h: "degree h1 = i" by auto
from arg_cong[OF gh, of degree] g0 have "degree g = degree h1 + degree h2"
by (simp add: degree_mult_eq gh)
with **(1) deg_h have "degree h2 = 0" by auto
from degree0_coeffs[OF this] obtain c where h2: "h2 = [:c:]" by auto
with gh g0 have g: "g = smult c h1" "c ≠ 0" by auto
with irr **(2) irreducible_smult_field[of c h1] have False by auto
}
ultimately show "irreducible g = (degree g = i)" by auto
qed
hide_const order
hide_const up_ring.monom
theorem (in field) finite_field_mult_group_has_gen2:
assumes finite:"finite (carrier R)"
shows "∃a ∈ carrier (mult_of R). group.ord (mult_of R) a = order (mult_of R)
∧ carrier (mult_of R) = {a[^]i | i::nat . i ∈ UNIV}"
proof -
note mult_of_simps[simp]
have finite': "finite (carrier (mult_of R))" using finite by (rule finite_mult_of)
interpret G: group "mult_of R" rewrites
"([^]⇘mult_of R⇙) = (([^]) :: _ ⇒ nat ⇒ _)" and "𝟭⇘mult_of R⇙ = 𝟭"
by (rule field_mult_group) (simp_all add: fun_eq_iff nat_pow_def)
let ?N = "λ x . card {a ∈ carrier (mult_of R). group.ord (mult_of R) a = x}"
have "0 < order R - 1" unfolding Coset.order_def using card_mono[OF finite, of "{𝟬, 𝟭}"] by simp
then have *: "0 < order (mult_of R)" using assms by (simp add: order_mult_of)
have fin: "finite {d. d dvd order (mult_of R) }" using dvd_nat_bounds[OF *] by force
have "(∑d | d dvd order (mult_of R). ?N d)
= card (UN d:{d . d dvd order (mult_of R) }. {a ∈ carrier (mult_of R). group.ord (mult_of R) a = d})"
(is "_ = card ?U")
using fin finite by (subst card_UN_disjoint) auto
also have "?U = carrier (mult_of R)"
proof
{ fix x assume x:"x ∈ carrier (mult_of R)"
hence x':"x∈carrier (mult_of R)" by simp
then have "group.ord (mult_of R) x dvd order (mult_of R)"
using finite' G.ord_dvd_group_order[OF x'] by (simp add: order_mult_of)
hence "x ∈ ?U" using dvd_nat_bounds[of "order (mult_of R)" "group.ord (mult_of R) x"] x by blast
} thus "carrier (mult_of R) ⊆ ?U" by blast
qed auto
also have "card ... = Coset.order (mult_of R)"
using order_mult_of finite' by (simp add: Coset.order_def)
finally have sum_Ns_eq: "(∑d | d dvd order (mult_of R). ?N d) = order (mult_of R)" .
{ fix d assume d:"d dvd order (mult_of R)"
have "card {a ∈ carrier (mult_of R). group.ord (mult_of R) a = d} ≤ phi' d"
proof cases
assume "card {a ∈ carrier (mult_of R). group.ord (mult_of R) a = d} = 0" thus ?thesis by presburger
next
assume "card {a ∈ carrier (mult_of R). group.ord (mult_of R) a = d} ≠ 0"
hence "∃a ∈ carrier (mult_of R). group.ord (mult_of R) a = d" by (auto simp: card_eq_0_iff)
thus ?thesis using num_elems_of_ord_eq_phi'[OF finite d] by auto
qed
}
hence all_le:"⋀i. i ∈ {d. d dvd order (mult_of R) }
⟹ (λi. card {a ∈ carrier (mult_of R). group.ord (mult_of R) a = i}) i ≤ (λi. phi' i) i" by fast
hence le:"(∑i | i dvd order (mult_of R). ?N i)
≤ (∑i | i dvd order (mult_of R). phi' i)"
using sum_mono[of "{d . d dvd order (mult_of R)}"
"λi. card {a ∈ carrier (mult_of R). group.ord (mult_of R) a = i}"] by presburger
have "order (mult_of R) = (∑d | d dvd order (mult_of R). phi' d)" using *
by (simp add: sum_phi'_factors)
hence eq:"(∑i | i dvd order (mult_of R). ?N i)
= (∑i | i dvd order (mult_of R). phi' i)" using le sum_Ns_eq by presburger
have "⋀i. i ∈ {d. d dvd order (mult_of R) } ⟹ ?N i = (λi. phi' i) i"
proof (rule ccontr)
fix i
assume i1:"i ∈ {d. d dvd order (mult_of R)}" and "?N i ≠ phi' i"
hence "?N i = 0"
using num_elems_of_ord_eq_phi'[OF finite, of i] by (auto simp: card_eq_0_iff)
moreover have "0 < i" using * i1 by (simp add: dvd_nat_bounds[of "order (mult_of R)" i])
ultimately have "?N i < phi' i" using phi'_nonzero by presburger
hence "(∑i | i dvd order (mult_of R). ?N i)
< (∑i | i dvd order (mult_of R). phi' i)"
using sum_strict_mono_ex1[OF fin, of "?N" "λ i . phi' i"]
i1 all_le by auto
thus False using eq by force
qed
hence "?N (order (mult_of R)) > 0" using * by (simp add: phi'_nonzero)
then obtain a where a:"a ∈ carrier (mult_of R)" and a_ord:"group.ord (mult_of R) a = order (mult_of R)"
by (auto simp add: card_gt_0_iff)
hence set_eq:"{a[^]i | i::nat. i ∈ UNIV} = (λx. a[^]x) ` {0 .. group.ord (mult_of R) a - 1}"
using G.ord_elems[OF finite'] by auto
have card_eq:"card ((λx. a[^]x) ` {0 .. group.ord (mult_of R) a - 1}) = card {0 .. group.ord (mult_of R) a - 1}"
by (intro card_image G.ord_inj finite' a)
hence "card ((λ x . a[^]x) ` {0 .. group.ord (mult_of R) a - 1}) = card {0 ..order (mult_of R) - 1}"
using assms by (simp add: card_eq a_ord)
hence card_R_minus_1:"card {a[^]i | i::nat. i ∈ UNIV} = order (mult_of R)"
using * by (subst set_eq) auto
have **:"{a[^]i | i::nat. i ∈ UNIV} ⊆ carrier (mult_of R)"
using G.nat_pow_closed[OF a] by auto
with _ have "carrier (mult_of R) = {a[^]i|i::nat. i ∈ UNIV}"
by (rule card_seteq[symmetric]) (simp_all add: card_R_minus_1 finite Coset.order_def del: UNIV_I)
thus ?thesis using a a_ord by blast
qed
lemma add_power_prime_poly_mod_ring[simp]:
fixes x :: "'a::{prime_card} mod_ring poly"
shows "(x + y) ^ CARD('a)^n = x ^ (CARD('a)^n) + y ^ CARD('a)^n"
proof (induct n arbitrary: x y)
case 0
then show ?case by auto
next
case (Suc n)
define p where p: "p = CARD('a)"
have "(x + y) ^ p ^ Suc n = (x + y) ^ (p * p^n)" by simp
also have "... = ((x + y) ^ p) ^ (p^n)"
by (simp add: power_mult)
also have "... = (x^p + y^p)^ (p^n)"
by (simp add: add_power_poly_mod_ring p)
also have "... = (x^p)^(p^n) + (y^p)^(p^n)" using Suc.hyps unfolding p by auto
also have "... = x^(p^(n+1)) + y^(p^(n+1))" by (simp add: power_mult)
finally show ?case by (simp add: p)
qed
lemma fermat_theorem_mod_ring2[simp]:
fixes a::"'a::{prime_card} mod_ring"
shows "a ^ (CARD('a)^n) = a"
proof (induct n arbitrary: a)
case (Suc n)
define p where "p = CARD('a)"
have "a ^ p ^ Suc n = a ^ (p * (p ^ n))" by simp
also have "... = (a ^ p) ^(p ^ n)" by (simp add: power_mult)
also have "... = a^(p ^ n)" using fermat_theorem_mod_ring[of "a^p"] unfolding p_def by auto
also have "... = a" using Suc.hyps p_def by auto
finally show ?case by (simp add: p_def)
qed auto
lemma fermat_theorem_power_poly[simp]:
fixes a::"'a::prime_card mod_ring"
shows "[:a:] ^ CARD('a::prime_card) ^ n = [:a:]"
by (auto simp add: Missing_Polynomial.poly_const_pow mod_poly_less)
lemma degree_prod_monom: "degree (∏i = 0..<n. monom 1 1) = n"
by (metis degree_monom_eq prod_pow x_pow_n zero_neq_one)
lemma degree_monom0[simp]: "degree (monom a 0) = 0" using degree_monom_le by auto
lemma degree_monom0'[simp]: "degree (monom 0 b) = 0" by auto
lemma sum_monom_mod:
assumes "b < degree f"
shows "(∑i≤b. monom (g i) i) mod f = (∑i≤b. monom (g i) i)"
using assms
proof (induct b)
case 0
then show ?case by (auto simp add: mod_poly_less)
next
case (Suc b)
have hyp: "(∑i≤b. monom (g i) i) mod f = (∑i≤b. monom (g i) i)"
using Suc.prems Suc.hyps by simp
have rw_monom: "monom (g (Suc b)) (Suc b) mod f = monom (g (Suc b)) (Suc b)"
by (metis Suc.prems degree_monom_eq mod_0 mod_poly_less monom_hom.hom_0_iff)
have rw: "(∑i≤Suc b. monom (g i) i) = (monom (g (Suc b)) (Suc b) + (∑i≤b. monom (g i) i))"
by auto
have "(∑i≤Suc b. monom (g i) i) mod f
= (monom (g (Suc b)) (Suc b) + (∑i≤b. monom (g i) i)) mod f" using rw by presburger
also have "... =((monom (g (Suc b)) (Suc b)) mod f) + ((∑i≤b. monom (g i) i) mod f)"
using poly_mod_add_left by auto
also have "... = monom (g (Suc b)) (Suc b) + (∑i≤b. monom (g i) i)"
using hyp rw_monom by presburger
also have "... = (∑i≤Suc b. monom (g i) i)" using rw by auto
finally show ?case .
qed
lemma x_power_aq_minus_1_rw:
fixes x::nat
assumes x: "x > 1"
and a: "a > 0"
and b: "b > 0"
shows "x ^ (a * q) - 1 = ((x^a) - 1) * sum ((^) (x^a)) {..<q}"
proof -
have xa: "(x ^ a) > 0" using x by auto
have int_rw1: "int (x ^ a) - 1 = int ((x ^ a) - 1)"
using xa by linarith
have int_rw2: "sum ((^) (int (x ^ a))) {..<q} = int (sum ((^) ((x ^ a))) {..<q})"
unfolding int_sum by simp
have "int (x ^ a) ^ q = int (Suc ((x ^ a) ^ q - 1))" using xa by auto
hence "int ((x ^ a) ^ q - 1) = int (x ^ a) ^ q - 1" using xa by presburger
also have "... = (int (x ^ a) - 1) * sum ((^) (int (x ^ a))) {..<q}"
by (rule power_diff_1_eq)
also have "... = (int ((x ^ a) - 1)) * int (sum ((^) ( (x ^ a))) {..<q})"
unfolding int_rw1 int_rw2 by simp
also have "... = int (((x ^ a) - 1) * (sum ((^) ( (x ^ a))) {..<q}))" by auto
finally have aux: "int ((x ^ a) ^ q - 1) = int (((x ^ a) - 1) * sum ((^) (x ^ a)) {..<q})" .
have "x ^ (a * q) - 1 = (x^a)^q - 1"
by (simp add: power_mult)
also have "... = ((x^a) - 1) * sum ((^) (x^a)) {..<q}"
using aux unfolding int_int_eq .
finally show ?thesis .
qed
lemma dvd_power_minus_1_conv1:
fixes x::nat
assumes x: "x > 1"
and a: "a > 0"
and xa_dvd: "x ^ a - 1 dvd x^b - 1"
and b0: "b > 0"
shows "a dvd b"
proof -
define r where r[simp]: "r = b mod a"
define q where q[simp]: "q = b div a"
have b: "b = a * q + r" by auto
have ra: "r < a" by (simp add: a)
hence xr_less_xa: "x ^ r - 1 < x ^ a - 1"
using x power_strict_increasing_iff diff_less_mono x by simp
have dvd: "x ^ a - 1 dvd x ^ (a * q) - 1"
using x_power_aq_minus_1_rw[OF x a b0] unfolding dvd_def by auto
have "x^b - 1 = x^b - x^r + x^r - 1"
using assms(1) assms(4) by auto
also have "... = x^r * (x^(a*q) - 1) + x^r - 1"
by (metis (no_types, lifting) b diff_mult_distrib2 mult.commute nat_mult_1_right power_add)
finally have "x^b - 1 = x^r * (x^(a*q) - 1) + x^r - 1" .
hence "x ^ a - 1 dvd x ^ r * (x ^ (a * q) - 1) + x ^ r - 1" using xa_dvd by presburger
hence "x^a - 1 dvd x^r - 1"
by (metis (no_types) diff_add_inverse diff_commute dvd dvd_diff_nat dvd_trans dvd_triv_right)
hence "r = 0"
using xr_less_xa
by (meson nat_dvd_not_less neq0_conv one_less_power x zero_less_diff)
thus ?thesis by auto
qed
lemma dvd_power_minus_1_conv2:
fixes x::nat
assumes x: "x > 1"
and a: "a > 0"
and a_dvd_b: "a dvd b"
and b0: "b > 0"
shows "x ^ a - 1 dvd x^b - 1"
proof -
define q where q[simp]: "q = b div a"
have b: "b = a * q" using a_dvd_b by auto
have "x^b - 1 = ((x ^ a) - 1) * sum ((^) (x ^ a)) {..<q}"
unfolding b by (rule x_power_aq_minus_1_rw[OF x a b0])
thus ?thesis unfolding dvd_def by auto
qed
corollary dvd_power_minus_1_conv:
fixes x::nat
assumes x: "x > 1"
and a: "a > 0"
and b0: "b > 0"
shows "a dvd b = (x ^ a - 1 dvd x^b - 1)"
using assms dvd_power_minus_1_conv1 dvd_power_minus_1_conv2 by blast
locale poly_mod_type_irr = poly_mod_type m "TYPE('a::prime_card)" for m +
fixes f::"'a::{prime_card} mod_ring poly"
assumes irr_f: "irreducible⇩d f"
begin
definition plus_irr :: "'a mod_ring poly ⇒'a mod_ring poly ⇒ 'a mod_ring poly"
where "plus_irr a b = (a + b) mod f"
definition minus_irr :: "'a mod_ring poly ⇒'a mod_ring poly ⇒ 'a mod_ring poly"
where "minus_irr x y ≡ (x - y) mod f"
definition uminus_irr :: "'a mod_ring poly ⇒'a mod_ring poly "
where "uminus_irr x = -x"
definition mult_irr :: "'a mod_ring poly ⇒'a mod_ring poly ⇒ 'a mod_ring poly"
where "mult_irr x y = ((x*y) mod f)"
definition carrier_irr :: "'a mod_ring poly set"
where "carrier_irr = {x. degree x < degree f}"
definition power_irr :: "'a mod_ring poly ⇒ nat ⇒ 'a mod_ring poly"
where "power_irr p n = ((p^n) mod f)"
definition "R = ⦇carrier = carrier_irr, monoid.mult = mult_irr, one = 1, zero = 0, add = plus_irr⦈"
lemma degree_f[simp]: "degree f > 0"
using irr_f irreducible⇩dD(1) by blast
lemma element_in_carrier: "(a ∈ carrier R) = (degree a < degree f)"
unfolding R_def carrier_irr_def by auto
lemma f_dvd_ab:
"a = 0 ∨ b = 0" if "f dvd a * b"
and a: "degree a < degree f"
and b: "degree b < degree f"
proof (rule ccontr)
assume "¬ (a = 0 ∨ b = 0)"
then have "a ≠ 0" and "b ≠ 0"
by simp_all
with a b have "¬ f dvd a" and "¬ f dvd b"
by (auto simp add: mod_poly_less dvd_eq_mod_eq_0)
moreover from ‹f dvd a * b› irr_f have "f dvd a ∨ f dvd b"
by auto
ultimately show False
by simp
qed
lemma ab_mod_f0:
"a = 0 ∨ b = 0" if "a * b mod f = 0"
and a: "degree a < degree f"
and b: "degree b < degree f"
using that f_dvd_ab by auto
lemma irreducible⇩dD2:
fixes p q :: "'b::{comm_semiring_1,semiring_no_zero_divisors} poly"
assumes "irreducible⇩d p"
and "degree q < degree p" and "degree q ≠ 0"
shows "¬ q dvd p"
using assms irreducible⇩d_dvd_smult by force
lemma times_mod_f_1_imp_0:
assumes x: "degree x < degree f"
and x2: "∀xa. x * xa mod f = 1 ⟶ ¬ degree xa < degree f"
shows "x = 0"
proof (rule ccontr)
assume x3: "x ≠ 0"
let ?u = "fst (bezout_coefficients f x)"
let ?v = "snd (bezout_coefficients f x)"
have "?u * f + ?v * x = gcd f x" using bezout_coefficients_fst_snd by auto
also have "... = 1"
proof (rule ccontr)
assume g: "gcd f x ≠ 1"
have "degree (gcd f x) < degree f"
by (metis degree_0 dvd_eq_mod_eq_0 gcd_dvd1 gcd_dvd2 irr_f
irreducible⇩dD(1) mod_poly_less nat_neq_iff x x3)
have "¬ gcd f x dvd f"
proof (rule irreducible⇩dD2[OF irr_f])
show "degree (gcd f x) < degree f"
by (metis degree_0 dvd_eq_mod_eq_0 gcd_dvd1 gcd_dvd2 irr_f
irreducible⇩dD(1) mod_poly_less nat_neq_iff x x3)
show "degree (gcd f x) ≠ 0"
by (metis (no_types, hide_lams) g degree_mod_less' gcd.bottom_left_bottom gcd_eq_0_iff
gcd_left_idem gcd_mod_left gr_implies_not0 x)
qed
moreover have "gcd f x dvd f" by auto
ultimately show False by contradiction
qed
finally have "?v*x mod f = 1"
by (metis degree_1 degree_f mod_mult_self3 mod_poly_less)
hence "(x*(?v mod f)) mod f = 1"
by (simp add: mod_mult_right_eq mult.commute)
moreover have "degree (?v mod f) < degree f"
by (metis degree_0 degree_f degree_mod_less' not_gr_zero)
ultimately show False using x2 by auto
qed
sublocale field_R: field R
proof -
have *: "∃y. degree y < degree f ∧ f dvd x + y" if "degree x < degree f"
for x :: "'a mod_ring poly"
proof -
from that have "degree (- x) < degree f"
by simp
moreover have "f dvd (x + - x)"
by simp
ultimately show ?thesis
by blast
qed
have **: "degree (x * y mod f) < degree f"
if "degree x < degree f" and "degree y < degree f"
for x y :: "'a mod_ring poly"
using that by (cases "x = 0 ∨ y = 0")
(auto intro: degree_mod_less' dest: f_dvd_ab)
show "field R"
by standard (auto simp add: R_def carrier_irr_def plus_irr_def mult_irr_def Units_def algebra_simps degree_add_less mod_poly_less mod_add_eq mult_poly_add_left mod_mult_left_eq mod_mult_right_eq mod_eq_0_iff_dvd ab_mod_f0 * ** dest: times_mod_f_1_imp_0)
qed
lemma zero_in_carrier[simp]: "0 ∈ carrier_irr" unfolding carrier_irr_def by auto
lemma card_carrier_irr[simp]: "card carrier_irr = CARD('a)^(degree f)"
proof -
let ?A = "(carrier_vec (degree f):: 'a mod_ring vec set)"
have bij_A_carrier: "bij_betw (Poly ∘ list_of_vec) ?A carrier_irr"
proof (unfold bij_betw_def, rule conjI)
show "inj_on (Poly ∘ list_of_vec) ?A" by (rule inj_Poly_list_of_vec)
show "(Poly ∘ list_of_vec) ` ?A = carrier_irr"
proof (unfold image_def o_def carrier_irr_def, auto)
fix xa assume "xa ∈ ?A" thus "degree (Poly (list_of_vec xa)) < degree f"
using degree_Poly_list_of_vec irr_f by blast
next
fix x::"'a mod_ring poly"
assume deg_x: "degree x < degree f"
let ?xa = "vec_of_list (coeffs x @ replicate (degree f - length (coeffs x)) 0)"
show "∃xa∈carrier_vec (degree f). x = Poly (list_of_vec xa)"
by (rule bexI[of _ "?xa"], unfold carrier_vec_def, insert deg_x)
(auto simp add: degree_eq_length_coeffs)
qed
qed
have "CARD('a)^(degree f) = card ?A"
by (simp add: card_carrier_vec)
also have "... = card carrier_irr" using bij_A_carrier bij_betw_same_card by blast
finally show ?thesis ..
qed
lemma finite_carrier_irr[simp]: "finite (carrier_irr)"
proof -
have "degree f > degree 0" using degree_0 by auto
hence "carrier_irr ≠ {}" using degree_0 unfolding carrier_irr_def
by blast
moreover have "card carrier_irr ≠ 0" by auto
ultimately show ?thesis using card_eq_0_iff by metis
qed
lemma finite_carrier_R[simp]: "finite (carrier R)" unfolding R_def by simp
lemma finite_carrier_mult_of[simp]: "finite (carrier (mult_of R))"
unfolding carrier_mult_of by auto
lemma constant_in_carrier[simp]: "[:a:] ∈ carrier R"
unfolding R_def carrier_irr_def by auto
lemma mod_in_carrier[simp]: "a mod f ∈ carrier R"
unfolding R_def carrier_irr_def
by (auto, metis degree_0 degree_f degree_mod_less' less_not_refl)
lemma order_irr: "Coset.order (mult_of R) = CARD('a)^degree f - 1"
by (simp add: card_Diff_singleton Coset.order_def carrier_mult_of R_def)
lemma element_power_order_eq_1:
assumes x: "x ∈ carrier (mult_of R)"
shows "x [^]⇘(mult_of R)⇙ Coset.order (mult_of R) = 𝟭⇘(mult_of R)⇙"
by (meson field_R.field_mult_group finite_carrier_mult_of group.pow_order_eq_1 x)
corollary element_power_order_eq_1':
assumes x: "x ∈ carrier (mult_of R)"
shows"x [^]⇘(mult_of R)⇙ CARD('a)^degree f = x"
proof -
have "x [^]⇘(mult_of R)⇙ CARD('a)^degree f
= x ⊗⇘(mult_of R)⇙ x [^]⇘(mult_of R)⇙ (CARD('a)^degree f - 1)"
by (metis Diff_iff One_nat_def Suc_pred field_R.m_comm field_R.nat_pow_Suc field_R.nat_pow_closed
mult_of_simps(1) mult_of_simps(2) nat_pow_mult_of neq0_conv power_eq_0_iff x zero_less_card_finite)
also have "x ⊗⇘(mult_of R)⇙ x [^]⇘(mult_of R)⇙ (CARD('a)^degree f - 1) = x"
by (metis carrier_mult_of element_power_order_eq_1 field_R.Units_closed field_R.field_Units
field_R.r_one monoid.simps(2) mult_mult_of mult_of_def order_irr x)
finally show ?thesis .
qed
lemma pow_irr[simp]: "x [^]⇘(R)⇙ n= x^n mod f"
by (induct n, auto simp add: mod_poly_less nat_pow_def R_def mult_of_def mult_irr_def
carrier_irr_def mod_mult_right_eq mult.commute)
lemma pow_irr_mult_of[simp]: "x [^]⇘(mult_of R)⇙ n= x^n mod f"
by (induct n, auto simp add: mod_poly_less nat_pow_def R_def mult_of_def mult_irr_def
carrier_irr_def mod_mult_right_eq mult.commute)
lemma fermat_theorem_power_poly_R[simp]: "[:a:] [^]⇘R⇙ CARD('a) ^ n = [:a:]"
by (auto simp add: Missing_Polynomial.poly_const_pow mod_poly_less)
lemma times_mod_expand:
"(a ⊗⇘(R)⇙ b) = ((a mod f) ⊗⇘(R)⇙ (b mod f))"
by (simp add: mod_mult_eq R_def mult_irr_def)
lemma mult_closed_power:
assumes x: "x ∈ carrier R" and y: "y ∈ carrier R"
and "x [^]⇘(R)⇙ CARD('a) ^ m' = x"
and "y [^]⇘(R)⇙ CARD('a) ^ m' = y"
shows "(x ⊗⇘(R)⇙ y) [^]⇘(R)⇙ CARD('a) ^ m' = (x ⊗⇘(R)⇙ y)"
using assms assms field_R.nat_pow_distrib by auto
lemma add_closed_power:
assumes x1: "x [^]⇘(R)⇙ CARD('a) ^ m' = x"
and y1: "y [^]⇘(R)⇙ CARD('a) ^ m' = y"
shows "(x ⊕⇘(R)⇙ y) [^]⇘(R)⇙ CARD('a) ^ m' = (x ⊕⇘(R)⇙ y)"
proof -
have "(x + y) ^ CARD('a) ^ m' = x^(CARD('a) ^ m') + y ^ (CARD('a) ^ m')" by auto
hence "(x + y) ^ CARD('a) ^ m' mod f = (x^(CARD('a) ^ m') + y ^ (CARD('a) ^ m')) mod f" by auto
hence "(x ⊕⇘(R)⇙ y) [^]⇘(R)⇙ CARD('a) ^ m'
= (x [^]⇘(R)⇙ CARD('a)^m') ⊕⇘(R)⇙ (y [^]⇘(R)⇙ CARD('a)^m')"
by (auto, unfold R_def plus_irr_def, auto simp add: mod_add_eq power_mod)
also have "... = x ⊕⇘(R)⇙ y" unfolding x1 y1 by simp
finally show ?thesis .
qed
lemma x_power_pm_minus_1:
assumes x: "x ∈ carrier (mult_of R)"
and "x [^]⇘(R)⇙ CARD('a) ^ m' = x"
shows "x [^]⇘(R)⇙ (CARD('a) ^ m' - 1) = 𝟭⇘(R)⇙"
by (metis (no_types, lifting) One_nat_def Suc_pred assms(2) carrier_mult_of field_R.Units_closed
field_R.Units_l_cancel field_R.field_Units field_R.l_one field_R.m_rcancel field_R.nat_pow_Suc
field_R.nat_pow_closed field_R.one_closed field_R.r_null field_R.r_one x zero_less_card_finite
zero_less_power)
context
begin
private lemma monom_a_1_P:
assumes m: "monom 1 1 ∈ carrier R"
and eq: "monom 1 1 [^]⇘(R)⇙ (CARD('a) ^ m') = monom 1 1"
shows "monom a 1 [^]⇘(R)⇙ (CARD('a) ^ m') = monom a 1"
proof -
have "monom a 1 = [:a:] * (monom 1 1)"
by (metis One_nat_def monom_0 monom_Suc mult.commute pCons_0_as_mult)
also have "... = [:a:] ⊗⇘(R)⇙ (monom 1 1)"
by (auto simp add: R_def mult_irr_def)
(metis One_nat_def assms(2) mod_mod_trivial mod_smult_left pow_irr)
finally have eq2: "monom a 1 = [:a:] ⊗⇘R⇙ monom 1 1" .
show ?thesis unfolding eq2
by (rule mult_closed_power[OF _ m _ eq], insert fermat_theorem_power_poly_R, auto)
qed
private lemma prod_monom_1_1:
defines "P == (λ x n. (x[^]⇘(R)⇙ (CARD('a) ^ n) = x))"
assumes m: "monom 1 1 ∈ carrier R"
and eq: "P (monom 1 1) n"
shows "P ((∏i = 0..<b::nat. monom 1 1) mod f) n"
proof (induct b)
case 0
then show ?case unfolding P_def
by (simp add: power_mod)
next
case (Suc b)
let ?N = "(∏i = 0..<b. monom 1 1)"
have eq2: "(∏i = 0..<Suc b. monom 1 1) mod f = monom 1 1 ⊗⇘(R)⇙ (∏i = 0..<b. monom 1 1)"
by (metis field_R.m_comm field_R.nat_pow_Suc mod_in_carrier mod_mod_trivial
pow_irr prod_pow times_mod_expand)
also have "... = (monom 1 1 mod f) ⊗⇘(R)⇙ ((∏i = 0..<b. monom 1 1) mod f)"
by (rule times_mod_expand)
finally have eq2: "(∏i = 0..<Suc b. monom 1 1) mod f
= (monom 1 1 mod f) ⊗⇘(R)⇙ ((∏i = 0..<b. monom 1 1) mod f)" .
show ?case
unfolding eq2 P_def
proof (rule mult_closed_power)
show "(monom 1 1 mod f) [^]⇘R⇙ CARD('a) ^ n = monom 1 1 mod f"
using P_def element_in_carrier eq m mod_poly_less by force
show "((∏i = 0..<b. monom 1 1) mod f) [^]⇘R⇙ CARD('a) ^ n = (∏i = 0..<b. monom 1 1) mod f"
using P_def Suc.hyps by blast
qed (auto)
qed
private lemma monom_1_b:
defines "P == (λ x n. (x[^]⇘(R)⇙ (CARD('a) ^ n) = x))"
assumes m: "monom 1 1 ∈ carrier R"
and monom_1_1: "P (monom 1 1) m'"
and b: "b < degree f"
shows "P (monom 1 b) m'"
proof -
have "monom 1 b = (∏i = 0..<b. monom 1 1)"
by (metis prod_pow x_pow_n)
also have "... = (∏i = 0..<b. monom 1 1) mod f"
by (rule mod_poly_less[symmetric], auto)
(metis One_nat_def b degree_linear_power x_as_monom)
finally have eq2: "monom 1 b = (∏i = 0..<b. monom 1 1) mod f" .
show ?thesis unfolding eq2 P_def
by (rule prod_monom_1_1[OF m monom_1_1[unfolded P_def]])
qed
private lemma monom_a_b:
defines "P == (λ x n. (x[^]⇘(R)⇙ (CARD('a) ^ n) = x))"
assumes m: "monom 1 1 ∈ carrier R"
and m1: "P (monom 1 1) m'"
and b: "b < degree f"
shows "P (monom a b) m'"
proof -
have "monom a b = smult a (monom 1 b)"
by (simp add: smult_monom)
also have "... = [:a:] * (monom 1 b)" by auto
also have "... = [:a:] ⊗⇘(R)⇙ (monom 1 b)"
unfolding R_def mult_irr_def
by (simp add: b degree_monom_eq mod_poly_less)
finally have eq: "monom a b = [:a:] ⊗⇘(R)⇙ (monom 1 b)" .
show ?thesis unfolding eq P_def
proof (rule mult_closed_power)
show "[:a:] [^]⇘R⇙ CARD('a) ^ m' = [:a:]" by (rule fermat_theorem_power_poly_R)
show "monom 1 b [^]⇘R⇙ CARD('a) ^ m' = monom 1 b"
unfolding P_def by (rule monom_1_b[OF m m1[unfolded P_def] b])
show "monom 1 b ∈ carrier R" unfolding element_in_carrier using b
by (simp add: degree_monom_eq)
qed (auto)
qed
private lemma sum_monoms_P:
defines "P == (λ x n. (x[^]⇘(R)⇙ (CARD('a) ^ n) = x))"
assumes m: "monom 1 1 ∈ carrier R"
and monom_1_1: "P (monom 1 1) n"
and b: "b < degree f"
shows "P ((∑i≤b. monom (g i) i)) n"
using b
proof (induct b)
case 0
then show ?case unfolding P_def
by (simp add: poly_const_pow mod_poly_less monom_0)
next
case (Suc b)
have b: "b < degree f" using Suc.prems by auto
have rw: "(∑i≤b. monom (g i) i) mod f = (∑i≤b. monom (g i) i)" by (rule sum_monom_mod[OF b])
have rw2: "(monom (g (Suc b)) (Suc b) mod f) = monom (g (Suc b)) (Suc b)"
by (metis Suc.prems field_R.nat_pow_eone m monom_a_b pow_irr power_0 power_one_right)
have hyp: "P (∑i≤b. monom (g i) i) n" using Suc.prems Suc.hyps by auto
have "(∑i≤Suc b. monom (g i) i) = monom (g (Suc b)) (Suc b) + (∑i≤b. monom (g i) i)"
by simp
also have "... = (monom (g (Suc b)) (Suc b) mod f) + ((∑i≤b. monom (g i) i) mod f)"
using rw rw2 by argo
also have "... = monom (g (Suc b)) (Suc b) ⊕⇘R⇙ (∑i≤b. monom (g i) i)"
unfolding R_def plus_irr_def
by (simp add: poly_mod_add_left)
finally have eq: "(∑i≤Suc b. monom (g i) i)
= monom (g (Suc b)) (Suc b) ⊕⇘R⇙ (∑i≤b. monom (g i) i)" .
show ?case unfolding eq P_def
proof (rule add_closed_power)
show "monom (g (Suc b)) (Suc b) [^]⇘R⇙ CARD('a) ^ n = monom (g (Suc b)) (Suc b)"
by (rule monom_a_b[OF m monom_1_1[unfolded P_def] Suc.prems])
show "(∑i≤b. monom (g i) i) [^]⇘R⇙ CARD('a) ^ n = (∑i≤b. monom (g i) i)"
using hyp unfolding P_def by simp
qed
qed
lemma element_carrier_P:
defines "P ≡ (λ x n. (x[^]⇘(R)⇙ (CARD('a) ^ n) = x))"
assumes m: "monom 1 1 ∈ carrier R"
and monom_1_1: "P (monom 1 1) m'"
and a: "a ∈ carrier R"
shows "P a m'"
proof -
have degree_a: "degree a < degree f" using a element_in_carrier by simp
have "P (∑i≤degree a. monom (poly.coeff a i) i) m'"
unfolding P_def
by (rule sum_monoms_P[OF m monom_1_1[unfolded P_def] degree_a])
thus ?thesis unfolding poly_as_sum_of_monoms by simp
qed
end
end
lemma degree_divisor1:
assumes f: "irreducible (f :: 'a :: prime_card mod_ring poly)"
and d: "degree f = d"
shows "f dvd (monom 1 1)^(CARD('a)^d) - monom 1 1"
proof -
interpret poly_mod_type_irr "CARD('a)" f by (unfold_locales, auto simp add: f)
show ?thesis
proof (cases "d = 1")
case True
show ?thesis
proof (cases "monom 1 1 mod f = 0")
case True
then show ?thesis
by (metis Suc_pred dvd_diff dvd_mult2 mod_eq_0_iff_dvd power.simps(2)
zero_less_card_finite zero_less_power)
next
case False note mod_f_not0 = False
have "monom 1 (CARD('a)) mod f = monom 1 1 mod f"
proof -
let ?g1 = "(monom 1 (CARD('a))) mod f"
let ?g2 = "(monom 1 1) mod f"
have deg_g1: "degree ?g1 < degree f" and deg_g2: "degree ?g2 < degree f"
by (metis True card_UNIV_unit d degree_0 degree_mod_less' zero_less_card_finite zero_neq_one)+
have g2: "?g2 [^]⇘(mult_of R)⇙ CARD('a)^degree f = ?g2 ^ (CARD('a)^degree f) mod f"
by (rule pow_irr_mult_of)
have "?g2 [^]⇘(mult_of R)⇙ CARD('a)^degree f = ?g2"
by (rule element_power_order_eq_1', insert mod_f_not0 deg_g2,
auto simp add: carrier_mult_of R_def carrier_irr_def )
hence "?g2 ^ CARD('a) mod f = ?g2 mod f" using True d by auto
hence "?g1 mod f = ?g2 mod f" by (metis mod_mod_trivial power_mod x_pow_n)
thus ?thesis by simp
qed
thus ?thesis by (metis True mod_eq_dvd_iff_poly power_one_right x_pow_n)
qed
next
case False
have deg_f1: "1 < degree f"
using False d degree_f by linarith
have "monom 1 1 [^]⇘(mult_of R)⇙ CARD('a)^degree f = monom 1 1"
by (rule element_power_order_eq_1', insert deg_f1)
(auto simp add: carrier_mult_of R_def carrier_irr_def degree_monom_eq)
hence "monom 1 1^CARD('a)^degree f mod f = monom 1 1 mod f"
using deg_f1 by (auto, metis mod_mod_trivial)
thus ?thesis using d mod_eq_dvd_iff_poly by blast
qed
qed
lemma degree_divisor2:
assumes f: "irreducible (f :: 'a :: prime_card mod_ring poly)"
and d: "degree f = d"
and c_ge_1: "1 ≤ c" and cd: "c < d"
shows "¬ f dvd monom 1 1 ^ CARD('a) ^ c - monom 1 1"
proof (rule ccontr)
interpret poly_mod_type_irr "CARD('a)" f by (unfold_locales, auto simp add: f)
have field_R: "field R"
by (simp add: field_R.field_axioms)
assume "¬ ¬ f dvd monom 1 1 ^ CARD('a) ^ c - monom 1 1"
hence f_dvd: "f dvd monom 1 1 ^ CARD('a) ^ c - monom 1 1" by simp
obtain a where a_R: "a ∈ carrier (mult_of R)"
and ord_a: "group.ord (mult_of R) a = order (mult_of R)"
and gen: "carrier (mult_of R) = {a [^]⇘R⇙ i |i. i ∈ (UNIV::nat set)}"
using field.finite_field_mult_group_has_gen2[OF field_R] by auto
have d_not1: "d>1" using c_ge_1 cd by auto
have monom_in_carrier: "monom 1 1 ∈ carrier (mult_of R)"
using d_not1 unfolding carrier_mult_of R_def carrier_irr_def
by (simp add: d degree_monom_eq)
then have "monom 1 1 ∉ {𝟬⇘R⇙}"
by auto
then obtain k where "monom 1 1 = a ^ k mod f"
using gen monom_in_carrier by auto
then have k: "a [^]⇘R⇙ k = monom 1 1"
by simp
have a_m_1: "a [^]⇘R⇙ (CARD('a)^c - 1) = 𝟭⇘R⇙"
proof (rule x_power_pm_minus_1[OF a_R])
let ?x = "monom 1 1::'a mod_ring poly"
show "a [^]⇘R⇙ CARD('a) ^ c = a"
proof (rule element_carrier_P)
show "?x ∈ carrier R"
by (metis k mod_in_carrier pow_irr)
have "?x ^ CARD('a)^ c mod f = ?x mod f" using f_dvd
using mod_eq_dvd_iff_poly by blast
thus "?x [^]⇘R⇙ CARD('a)^ c = ?x"
by (metis d d_not1 degree_monom_eq mod_poly_less one_neq_zero pow_irr)
show "a ∈ carrier R" using a_R unfolding carrier_mult_of by auto
qed
qed
have "Group.group (mult_of R)"
by (simp add: field_R.field_mult_group)
moreover have "finite (carrier (mult_of R))" by auto
moreover have "a ∈ carrier (mult_of R)" by (rule a_R )
moreover have "a [^]⇘mult_of R⇙ (CARD('a) ^ c - 1) = 𝟭⇘mult_of R⇙"
using a_m_1 unfolding mult_of_def
by (auto, metis mult_of_def pow_irr_mult_of nat_pow_mult_of)
ultimately have ord_dvd: "group.ord (mult_of R) a dvd (CARD('a)^c - 1)"
by (meson group.pow_eq_id)
have "d dvd c"
proof (rule dvd_power_minus_1_conv1[OF nontriv])
show "0 < d" using cd by auto
show "CARD('a) ^ d - 1 dvd CARD('a) ^ c - 1"
using ord_dvd by (simp add: d ord_a order_irr)
show "0 < c" using c_ge_1 by auto
qed
thus False using c_ge_1 cd
using nat_dvd_not_less by auto
qed
lemma degree_divisor: assumes "irreducible (f :: 'a :: prime_card mod_ring poly)" "degree f = d"
shows "f dvd (monom 1 1)^(CARD('a)^d) - monom 1 1"
and "1 ≤ c ⟹ c < d ⟹ ¬ f dvd (monom 1 1)^(CARD('a)^c) - monom 1 1"
using assms degree_divisor1 degree_divisor2 by blast+
context
assumes "SORT_CONSTRAINT('a :: prime_card)"
begin
function dist_degree_factorize_main ::
"'a mod_ring poly ⇒ 'a mod_ring poly ⇒ nat ⇒ (nat × 'a mod_ring poly) list
⇒ (nat × 'a mod_ring poly) list" where
"dist_degree_factorize_main v w d res = (if v = 1 then res else if d + d > degree v
then (degree v, v) # res else let
w = w^(CARD('a)) mod v;
d = Suc d;
gd = gcd (w - monom 1 1) v
in if gd = 1 then dist_degree_factorize_main v w d res else
let v' = v div gd in
dist_degree_factorize_main v' (w mod v') d ((d,gd) # res))"
by pat_completeness auto
termination
proof (relation "measure (λ (v,w,d,res). Suc (degree v) - d)", goal_cases)
case (3 v w d res x xa xb xc)
have "xb dvd v" unfolding 3 by auto
hence "xc dvd v" unfolding 3 by (metis dvd_def dvd_div_mult_self)
from divides_degree[OF this] 3
show ?case by auto
qed auto
declare dist_degree_factorize_main.simps[simp del]
lemma dist_degree_factorize_main: assumes
dist: "dist_degree_factorize_main v w d res = facts" and
w: "w = (monom 1 1)^(CARD('a)^d) mod v" and
sf: "square_free u" and
mon: "monic u" and
prod: "u = v * prod_list (map snd res)" and
deg: "⋀ f. irreducible f ⟹ f dvd v ⟹ degree f > d" and
res: "⋀ i f. (i,f) ∈ set res ⟹ i ≠ 0 ∧ degree f ≠ 0 ∧ monic f ∧ (∀ g. irreducible g ⟶ g dvd f ⟶ degree g = i)"
shows "u = prod_list (map snd facts) ∧ (∀ i f. (i,f) ∈ set facts ⟶ factors_of_same_degree i f)"
using dist w prod res deg unfolding factors_of_same_degree_def
proof (induct v w d res rule: dist_degree_factorize_main.induct)
case (1 v w d res)
note IH = 1(1-2)
note result = 1(3)
note w = 1(4)
note u = 1(5)
note res = 1(6)
note fact = 1(7)
note [simp] = dist_degree_factorize_main.simps[of _ _ d]
let ?x = "monom 1 1 :: 'a mod_ring poly"
show ?case
proof (cases "v = 1")
case True
thus ?thesis using result u mon res by auto
next
case False note v = this
note IH = IH[OF this]
have mon_prod: "monic (prod_list (map snd res))" by (rule monic_prod_list, insert res, auto)
with mon[unfolded u] have mon_v: "monic v" by (simp add: coeff_degree_mult)
with False have deg_v: "degree v ≠ 0" by (simp add: monic_degree_0)
show ?thesis
proof (cases "degree v < d + d")
case True
with result False have facts: "facts = (degree v, v) # res" by simp
show ?thesis
proof (intro allI conjI impI)
fix i f g
assume *: "(i,f) ∈ set facts" "irreducible g" "g dvd f"
show "degree g = i"
proof (cases "(i,f) ∈ set res")
case True
from res[OF this] * show ?thesis by auto
next
case False
with * facts have id: "i = degree v" "f = v" by auto
note * = *(2-3)[unfolded id]
from fact[OF *] have dg: "d < degree g" by auto
from divides_degree[OF *(2)] mon_v have deg_gv: "degree g ≤ degree v" by auto
from *(2) obtain h where vgh: "v = g * h" unfolding dvd_def by auto
from arg_cong[OF this, of degree] mon_v have dvgh: "degree v = degree g + degree h"
by (metis deg_v degree_mult_eq degree_mult_eq_0)
with dg deg_gv dg True have deg_h: "degree h < d" by auto
{
assume "degree h = 0"
with dvgh have "degree g = degree v" by simp
}
moreover
{
assume deg_h0: "degree h ≠ 0"
hence "∃ k. irreducible⇩d k ∧ k dvd h"
using dvd_triv_left irreducible⇩d_factor by blast
then obtain k where irr: "irreducible k" and "k dvd h" by auto
from dvd_trans[OF this(2), of v] vgh have "k dvd v" by auto
from fact[OF irr this] have dk: "d < degree k" .
from divides_degree[OF ‹k dvd h›] deg_h0 have "degree k ≤ degree h" by auto
with deg_h have "degree k < d" by auto
with dk have False by auto
}
ultimately have "degree g = degree v" by auto
thus ?thesis unfolding id by auto
qed
qed (insert v mon_v deg_v u facts res, force+)
next
case False
note IH = IH[OF this refl refl refl]
let ?p = "CARD('a)"
let ?w = "w ^ ?p mod v"
let ?g = "gcd (?w - ?x) v"
let ?v = "v div ?g"
let ?d = "Suc d"
from result[simplified] v False
have result: "(if ?g = 1 then dist_degree_factorize_main v ?w ?d res
else dist_degree_factorize_main ?v (?w mod ?v) ?d ((?d, ?g) # res)) = facts"
by (auto simp: Let_def)
from mon_v have mon_g: "monic ?g" by (metis deg_v degree_0 poly_gcd_monic)
have ww: "?w = ?x ^ ?p ^ ?d mod v" unfolding w
by simp (metis (mono_tags, hide_lams) One_nat_def mult.commute power_Suc power_mod power_mult x_pow_n)
have gv: "?g dvd v" by auto
hence gv': "v div ?g dvd v"
by (metis dvd_def dvd_div_mult_self)
{
fix f
assume irr: "irreducible f" and fv: "f dvd v" and "degree f = ?d"
from degree_divisor(1)[OF this(1,3)]
have "f dvd ?x ^ ?p ^ ?d - ?x" by auto
hence "f dvd (?x ^ ?p ^ ?d - ?x) mod v" using fv by (rule dvd_mod)
also have "(?x ^ ?p ^ ?d - ?x) mod v = ?x ^ ?p ^ ?d mod v - ?x mod v" by (rule poly_mod_diff_left)
also have "?x ^ ?p ^ ?d mod v = ?w mod v" unfolding ww by auto
also have "… - ?x mod v = (w ^ ?p mod v - ?x) mod v" by (metis poly_mod_diff_left)
finally have "f dvd (w^?p mod v - ?x)" using fv by (rule dvd_mod_imp_dvd)
with fv have "f dvd ?g" by auto
} note deg_d_dvd_g = this
show ?thesis
proof (cases "?g = 1")
case True
with result have dist: "dist_degree_factorize_main v ?w ?d res = facts" by auto
show ?thesis
proof (rule IH(1)[OF True dist ww u res])
fix f
assume irr: "irreducible f" and fv: "f dvd v"
from fact[OF this] have "d < degree f" .
moreover have "degree f ≠ ?d"
proof
assume "degree f = ?d"
from divides_degree[OF deg_d_dvd_g[OF irr fv this]] mon_v
have "degree f ≤ degree ?g" by auto
with irr have "degree ?g ≠ 0" unfolding irreducible⇩d_def by auto
with True show False by auto
qed
ultimately show "?d < degree f" by auto
qed
next
case False
with result
have result: "dist_degree_factorize_main ?v (?w mod ?v) ?d ((?d, ?g) # res) = facts"
by auto
from False mon_g have deg_g: "degree ?g ≠ 0" by (simp add: monic_degree_0)
have www: "?w mod ?v = monom 1 1 ^ ?p ^ ?d mod ?v" using gv'
by (simp add: mod_mod_cancel ww)
from square_free_factor[OF _ sf, of v] u have sfv: "square_free v" by auto
have u: "u = ?v * prod_list (map snd ((?d, ?g) # res))"
unfolding u by simp
show ?thesis
proof (rule IH(2)[OF False refl result www u], goal_cases)
case (1 i f)
show ?case
proof (cases "(i,f) ∈ set res")
case True
from res[OF this] show ?thesis by auto
next
case False
with 1 have id: "i = ?d" "f = ?g" by auto
show ?thesis unfolding id
proof (intro conjI impI allI)
fix g
assume *: "irreducible g" "g dvd ?g"
hence gv: "g dvd v" using dvd_trans[of g ?g v] by simp
from fact[OF *(1) this] have dg: "d < degree g" .
{
assume "degree g > ?d"
from degree_divisor(2)[OF *(1) refl _ this]
have ndvd: "¬ g dvd ?x ^ ?p ^ ?d - ?x" by auto
from *(2) have "g dvd ?w - ?x" by simp
from this[unfolded ww]
have "g dvd ?x ^ ?p ^ ?d mod v - ?x" .
with gv have "g dvd (?x ^ ?p ^ ?d mod v - ?x) mod v" by (metis dvd_mod)
also have "(?x ^ ?p ^ ?d mod v - ?x) mod v = (?x ^ ?p ^ ?d - ?x) mod v"
by (metis mod_diff_left_eq)
finally have "g dvd ?x ^ ?p ^ ?d - ?x" using gv by (rule dvd_mod_imp_dvd)
with ndvd have False by auto
}
with dg show "degree g = ?d" by presburger
qed (insert mon_g deg_g, auto)
qed
next
case (2 f)
note irr = 2(1)
from dvd_trans[OF 2(2) gv'] have fv: "f dvd v" .
from fact[OF irr fv] have df: "d < degree f" "degree f ≠ 0" by auto
{
assume "degree f = ?d"
from deg_d_dvd_g[OF irr fv this] have fg: "f dvd ?g" .
from gv have id: "v = (v div ?g) * ?g" by simp
from sfv id have "square_free (v div ?g * ?g)" by simp
from square_free_multD(1)[OF this 2(2) fg] have "degree f = 0" .
with df have False by auto
}
with df show "?d < degree f" by presburger
qed
qed
qed
qed
qed
definition distinct_degree_factorization
:: "'a mod_ring poly ⇒ (nat × 'a mod_ring poly) list" where
"distinct_degree_factorization f =
(if degree f = 1 then [(1,f)] else dist_degree_factorize_main f (monom 1 1) 0 [])"
lemma distinct_degree_factorization: assumes
dist: "distinct_degree_factorization f = facts" and
u: "square_free f" and
mon: "monic f"
shows "f = prod_list (map snd facts) ∧ (∀ i f. (i,f) ∈ set facts ⟶ factors_of_same_degree i f)"
proof -
note dist = dist[unfolded distinct_degree_factorization_def]
show ?thesis
proof (cases "degree f ≤ 1")
case False
hence "degree f > 1" and dist: "dist_degree_factorize_main f (monom 1 1) 0 [] = facts"
using dist by auto
hence *: "monom 1 (Suc 0) = monom 1 (Suc 0) mod f"
by (simp add: degree_monom_eq mod_poly_less)
show ?thesis
by (rule dist_degree_factorize_main[OF dist _ u mon], insert *, auto simp: irreducible⇩d_def)
next
case True
hence "degree f = 0 ∨ degree f = 1" by auto
thus ?thesis
proof
assume "degree f = 0"
with mon have f: "f = 1" using monic_degree_0 by blast
hence "facts = []" using dist unfolding dist_degree_factorize_main.simps[of _ _ 0]
by auto
thus ?thesis using f by auto
next
assume deg: "degree f = 1"
hence facts: "facts = [(1,f)]" using dist by auto
show ?thesis unfolding facts factors_of_same_degree_def
proof (intro conjI allI impI; clarsimp)
fix g
assume "irreducible g" "g dvd f"
thus "degree g = Suc 0" using deg divides_degree[of g f] by (auto simp: irreducible⇩d_def)
qed (insert mon deg, auto)
qed
qed
qed
end
end
Theory Finite_Field_Factorization
section ‹A Combined Factorization Algorithm for Polynomials over GF(p)›
subsection‹Type Based Version›
text ‹We combine Berlekamp's algorithm with the distinct degree factorization
to obtain an efficient factorization algorithm for square-free polynomials in GF(p).›
theory Finite_Field_Factorization
imports Berlekamp_Type_Based
Distinct_Degree_Factorization
begin
text ‹We prove soundness of the finite field factorization,
indepedendent on whether distinct-degree-factorization is
applied as preprocessing or not.›
consts use_distinct_degree_factorization :: bool
context
assumes "SORT_CONSTRAINT('a::prime_card)"
begin
definition finite_field_factorization :: "'a mod_ring poly ⇒ 'a mod_ring × 'a mod_ring poly list" where
"finite_field_factorization f = (if degree f = 0 then (lead_coeff f,[]) else let
a = lead_coeff f;
u = smult (inverse a) f;
gs = (if use_distinct_degree_factorization then distinct_degree_factorization u else [(1,u)]);
(irr,hs) = List.partition (λ (i,f). degree f = i) gs
in (a,map snd irr @ concat (map (λ (i,g). berlekamp_monic_factorization i g) hs)))"
lemma finite_field_factorization_explicit:
fixes f::"'a mod_ring poly"
assumes sf_f: "square_free f"
and us: "finite_field_factorization f = (c,us)"
shows "f = smult c (prod_list us) ∧ (∀ u ∈ set us. monic u ∧ irreducible u)"
proof (cases "degree f = 0")
case False note f = this
define g where "g = smult (inverse c) f"
obtain gs where dist: "(if use_distinct_degree_factorization then distinct_degree_factorization g else [(1,g)]) = gs" by auto
note us = us[unfolded finite_field_factorization_def Let_def]
from us f have c: "c = lead_coeff f" by auto
obtain irr hs where part: "List.partition (λ (i, f). degree f = i) gs = (irr,hs)" by force
from arg_cong[OF this, of fst] have irr: "irr = filter (λ (i, f). degree f = i) gs" by auto
from us[folded c, folded g_def, unfolded dist part split] f
have us: "us = map snd irr @ concat (map (λ(x, y). berlekamp_monic_factorization x y) hs)" by auto
from f c have c0: "c ≠ 0" by auto
from False c0 have deg_g: "degree g ≠ 0" unfolding g_def by auto
have mon_g: "monic g" unfolding g_def
by (metis c c0 field_class.field_inverse lead_coeff_smult)
from sf_f have sf_g: "square_free g" unfolding g_def by (simp add: c0)
from c0 have f: "f = smult c g" unfolding g_def by auto
have "g = prod_list (map snd gs) ∧ (∀ (i,f) ∈ set gs. degree f > 0 ∧ monic f ∧ (∀ h. h dvd f ⟶ degree h = i ⟶ irreducible h))"
proof (cases use_distinct_degree_factorization)
case True
with dist have "distinct_degree_factorization g = gs" by auto
note dist = distinct_degree_factorization[OF this sf_g mon_g]
from dist have g: "g = prod_list (map snd gs)" by auto
show ?thesis
proof (intro conjI[OF g] ballI, clarify)
fix i f
assume "(i,f) ∈ set gs"
with dist have "factors_of_same_degree i f" by auto
from factors_of_same_degreeD[OF this]
show "degree f > 0 ∧ monic f ∧ (∀h. h dvd f ⟶ degree h = i ⟶ irreducible h)" by auto
qed
next
case False
with dist have gs: "gs = [(1,g)]" by auto
show ?thesis unfolding gs using deg_g mon_g linear_irreducible⇩d[where 'a = "'a mod_ring"] by auto
qed
hence g_gs: "g = prod_list (map snd gs)"
and mon_gs: "⋀ i f. (i, f) ∈ set gs ⟹ monic f ∧ degree f > 0"
and irrI: "⋀ i f h . (i, f) ∈ set gs ⟹ h dvd f ⟹ degree h = i ⟹ irreducible h" by auto
have g: "g = prod_list (map snd irr) * prod_list (map snd hs)" unfolding g_gs
using prod_list_map_partition[OF part] .
{
fix f
assume "f ∈ snd ` set irr"
from this[unfolded irr] obtain i where *: "(i,f) ∈ set gs" "degree f = i" by auto
have "f dvd f" by auto
from irrI[OF *(1) this *(2)] mon_gs[OF *(1)] have "monic f" "irreducible f" by auto
} note irr = this
let ?berl = "λ hs. concat (map (λ(x, y). berlekamp_monic_factorization x y) hs)"
have "set hs ⊆ set gs" using part by auto
hence "prod_list (map snd hs) = prod_list (?berl hs)
∧ (∀ f ∈ set (?berl hs). monic f ∧ irreducible⇩d f)"
proof (induct hs)
case (Cons ih hs)
obtain i h where ih: "ih = (i,h)" by force
have "?berl (Cons ih hs) = berlekamp_monic_factorization i h @ ?berl hs" unfolding ih by auto
from Cons(2)[unfolded ih] have mem: "(i,h) ∈ set gs" and sub: "set hs ⊆ set gs" by auto
note IH = Cons(1)[OF sub]
from mem have "h ∈ set (map snd gs)" by force
from square_free_factor[OF prod_list_dvd[OF this], folded g_gs, OF sf_g] have sf: "square_free h" .
from mon_gs[OF mem] irrI[OF mem] have *: "degree h > 0" "monic h"
"⋀ g. g dvd h ⟹ degree g = i ⟹ irreducible g" by auto
from berlekamp_monic_factorization[OF sf refl *(3) *(1-2), of i]
have berl: "prod_list (berlekamp_monic_factorization i h) = h"
and irr: "⋀ f. f ∈ set (berlekamp_monic_factorization i h) ⟹ monic f ∧ irreducible f" by auto
have "prod_list (map snd (Cons ih hs)) = h * prod_list (map snd hs)" unfolding ih by simp
also have "prod_list (map snd hs) = prod_list (?berl hs)" using IH by auto
finally have "prod_list (map snd (Cons ih hs)) = prod_list (?berl (Cons ih hs))"
unfolding ih using berl by auto
thus ?case using IH irr unfolding ih by auto
qed auto
with g irr have main: "g = prod_list us ∧ (∀ u ∈ set us. monic u ∧ irreducible⇩d u)" unfolding us
by auto
thus ?thesis unfolding f using sf_g by auto
next
case True
with us[unfolded finite_field_factorization_def] have "c = lead_coeff f" and us: "us = []" by auto
with degree0_coeffs[OF True] have f: "f = [:c:]" by auto
show ?thesis unfolding us f by (auto simp: normalize_poly_def)
qed
lemma finite_field_factorization:
fixes f::"'a mod_ring poly"
assumes sf_f: "square_free f"
and us: "finite_field_factorization f = (c,us)"
shows "unique_factorization Irr_Mon f (c, mset us)"
proof -
from finite_field_factorization_explicit[OF sf_f us]
have fact: "factorization Irr_Mon f (c, mset us)"
unfolding factorization_def split Irr_Mon_def by (auto simp: prod_mset_prod_list)
from sf_f[unfolded square_free_def] have "f ≠ 0" by auto
from exactly_one_factorization[OF this] fact
show ?thesis unfolding unique_factorization_def by auto
qed
end
text ‹Experiments revealed that preprocessing via
distinct-degree-factorization slows down the factorization
algorithm (statement for implementation in AFP 2017)›
overloading use_distinct_degree_factorization ≡ use_distinct_degree_factorization
begin
definition use_distinct_degree_factorization
where [code_unfold]: "use_distinct_degree_factorization = False"
end
end
Theory Finite_Field_Factorization_Record_Based
subsection ‹Record Based Version›
theory Finite_Field_Factorization_Record_Based
imports
Finite_Field_Factorization
Matrix_Record_Based
Poly_Mod_Finite_Field_Record_Based
"HOL-Types_To_Sets.Types_To_Sets"
Jordan_Normal_Form.Matrix_IArray_Impl
Jordan_Normal_Form.Gauss_Jordan_IArray_Impl
Polynomial_Interpolation.Improved_Code_Equations
Polynomial_Factorization.Missing_List
begin
hide_const(open) monom coeff
text ‹Whereas @{thm finite_field_factorization} provides a result for a polynomials over GF(p),
we now develop a theorem which speaks about integer polynomials modulo p.›
lemma (in poly_mod_prime_type) finite_field_factorization_modulo_ring:
assumes g: "(g :: 'a mod_ring poly) = of_int_poly f"
and sf: "square_free_m f"
and fact: "finite_field_factorization g = (d,gs)"
and c: "c = to_int_mod_ring d"
and fs: "fs = map to_int_poly gs"
shows "unique_factorization_m f (c, mset fs)"
proof -
have [transfer_rule]: "MP_Rel f g" unfolding g MP_Rel_def by (simp add: Mp_f_representative)
have sg: "square_free g" by (transfer, rule sf)
have [transfer_rule]: "M_Rel c d" unfolding M_Rel_def c by (rule M_to_int_mod_ring)
have fs_gs[transfer_rule]: "list_all2 MP_Rel fs gs"
unfolding fs list_all2_map1 MP_Rel_def[abs_def] Mp_to_int_poly by (simp add: list.rel_refl)
have [transfer_rule]: "rel_mset MP_Rel (mset fs) (mset gs)"
using fs_gs using rel_mset_def by blast
have [transfer_rule]: "MF_Rel (c,mset fs) (d,mset gs)" unfolding MF_Rel_def by transfer_prover
from finite_field_factorization[OF sg fact]
have uf: "unique_factorization Irr_Mon g (d,mset gs)" by auto
from uf[untransferred] show "unique_factorization_m f (c, mset fs)" .
qed
text ‹We now have to implement @{const finite_field_factorization}.›
context
fixes p :: int
and ff_ops :: "'i arith_ops_record"
begin
fun power_poly_f_mod_i :: "('i list ⇒ 'i list) ⇒ 'i list ⇒ nat ⇒ 'i list" where
"power_poly_f_mod_i modulus a n = (if n = 0 then modulus (one_poly_i ff_ops)
else let (d,r) = Divides.divmod_nat n 2;
rec = power_poly_f_mod_i modulus (modulus (times_poly_i ff_ops a a)) d in
if r = 0 then rec else modulus (times_poly_i ff_ops rec a))"
declare power_poly_f_mod_i.simps[simp del]
fun power_polys_i :: "'i list ⇒ 'i list ⇒ 'i list ⇒ nat ⇒ 'i list list" where
"power_polys_i mul_p u curr_p (Suc i) = curr_p #
power_polys_i mul_p u (mod_field_poly_i ff_ops (times_poly_i ff_ops curr_p mul_p) u) i"
| "power_polys_i mul_p u curr_p 0 = []"
lemma length_power_polys_i[simp]: "length (power_polys_i x y z n) = n"
by (induct n arbitrary: x y z, auto)
definition berlekamp_mat_i :: "'i list ⇒ 'i mat" where
"berlekamp_mat_i u = (let n = degree_i u;
ze = arith_ops_record.zero ff_ops; on = arith_ops_record.one ff_ops;
mul_p = power_poly_f_mod_i (λ v. mod_field_poly_i ff_ops v u)
[ze, on] (nat p);
xks = power_polys_i mul_p u [on] n
in mat_of_rows_list n (map (λ cs. cs @ replicate (n - length cs) ze) xks))"
definition berlekamp_resulting_mat_i :: "'i list ⇒ 'i mat" where
"berlekamp_resulting_mat_i u = (let Q = berlekamp_mat_i u;
n = dim_row Q;
QI = mat n n (λ (i,j). if i = j then arith_ops_record.minus ff_ops (Q $$ (i,j)) (arith_ops_record.one ff_ops) else Q $$ (i,j))
in (gauss_jordan_single_i ff_ops (transpose_mat QI)))"
definition berlekamp_basis_i :: "'i list ⇒ 'i list list" where
"berlekamp_basis_i u = (map (poly_of_list_i ff_ops o list_of_vec)
(find_base_vectors_i ff_ops (berlekamp_resulting_mat_i u)))"
primrec berlekamp_factorization_main_i :: "'i ⇒ 'i ⇒ nat ⇒ 'i list list ⇒ 'i list list ⇒ nat ⇒ 'i list list" where
"berlekamp_factorization_main_i ze on d divs (v # vs) n = (
if v = [on] then berlekamp_factorization_main_i ze on d divs vs n else
if length divs = n then divs else
let of_int = arith_ops_record.of_int ff_ops;
facts = filter (λ w. w ≠ [on])
[ gcd_poly_i ff_ops u (minus_poly_i ff_ops v (if s = 0 then [] else [of_int (int s)])) .
u ← divs, s ← [0 ..< nat p]];
(lin,nonlin) = List.partition (λ q. degree_i q = d) facts
in lin @ berlekamp_factorization_main_i ze on d nonlin vs (n - length lin))"
| "berlekamp_factorization_main_i ze on d divs [] n = divs"
definition berlekamp_monic_factorization_i :: "nat ⇒ 'i list ⇒ 'i list list" where
"berlekamp_monic_factorization_i d f = (let
vs = berlekamp_basis_i f
in berlekamp_factorization_main_i (arith_ops_record.zero ff_ops) (arith_ops_record.one ff_ops) d [f] vs (length vs))"
partial_function (tailrec) dist_degree_factorize_main_i ::
"'i ⇒ 'i ⇒ nat ⇒ 'i list ⇒ 'i list ⇒ nat ⇒ (nat × 'i list) list
⇒ (nat × 'i list) list" where
[code]: "dist_degree_factorize_main_i ze on dv v w d res = (if v = [on] then res else if d + d > dv
then (dv, v) # res else let
w = power_poly_f_mod_i (λ f. mod_field_poly_i ff_ops f v) w (nat p);
d = Suc d;
gd = gcd_poly_i ff_ops (minus_poly_i ff_ops w [ze,on]) v
in if gd = [on] then dist_degree_factorize_main_i ze on dv v w d res else
let v' = div_field_poly_i ff_ops v gd
in dist_degree_factorize_main_i ze on (degree_i v') v' (mod_field_poly_i ff_ops w v') d ((d,gd) # res))"
definition distinct_degree_factorization_i
:: "'i list ⇒ (nat × 'i list) list" where
"distinct_degree_factorization_i f = (let ze = arith_ops_record.zero ff_ops;
on = arith_ops_record.one ff_ops in if degree_i f = 1 then [(1,f)] else
dist_degree_factorize_main_i ze on (degree_i f) f [ze,on] 0 [])"
definition finite_field_factorization_i :: "'i list ⇒ 'i × 'i list list" where
"finite_field_factorization_i f = (if degree_i f = 0 then (lead_coeff_i ff_ops f,[]) else let
a = lead_coeff_i ff_ops f;
u = smult_i ff_ops (arith_ops_record.inverse ff_ops a) f;
gs = (if use_distinct_degree_factorization then distinct_degree_factorization_i u else [(1,u)]);
(irr,hs) = List.partition (λ (i,f). degree_i f = i) gs
in (a,map snd irr @ concat (map (λ (i,g). berlekamp_monic_factorization_i i g) hs)))"
end
context prime_field_gen
begin
lemma power_polys_i: assumes i: "i < n" and [transfer_rule]: "poly_rel f f'" "poly_rel g g'"
and h: "poly_rel h h'"
shows "poly_rel (power_polys_i ff_ops g f h n ! i) (power_polys g' f' h' n ! i)"
using i h
proof (induct n arbitrary: h h' i)
case (Suc n h h' i) note * = this
note [transfer_rule] = *(3)
show ?case
proof (cases i)
case 0
with Suc show ?thesis by auto
next
case (Suc j)
with *(2-) have "j < n" by auto
note IH = *(1)[OF this]
show ?thesis unfolding Suc by (simp, rule IH, transfer_prover)
qed
qed simp
lemma power_poly_f_mod_i: assumes m: "(poly_rel ===> poly_rel) m (λ x'. x' mod m')"
shows "poly_rel f f' ⟹ poly_rel (power_poly_f_mod_i ff_ops m f n) (power_poly_f_mod m' f' n)"
proof -
from m have m: "⋀ x x'. poly_rel x x' ⟹ poly_rel (m x) (x' mod m')"
unfolding rel_fun_def by auto
show "poly_rel f f' ⟹ poly_rel (power_poly_f_mod_i ff_ops m f n) (power_poly_f_mod m' f' n)"
proof (induct n arbitrary: f f' rule: less_induct)
case (less n f f')
note f[transfer_rule] = less(2)
show ?case
proof (cases "n = 0")
case True
show ?thesis
by (simp add: True power_poly_f_mod_i.simps power_poly_f_mod_binary,
rule m[OF poly_rel_one])
next
case False
hence n: "(n = 0) = False" by simp
obtain q r where div: "Divides.divmod_nat n 2 = (q,r)" by force
from this[unfolded divmod_nat_def] n have "q < n" by auto
note IH = less(1)[OF this]
have rec: "poly_rel (power_poly_f_mod_i ff_ops m (m (times_poly_i ff_ops f f)) q)
(power_poly_f_mod m' (f' * f' mod m') q)"
by (rule IH, rule m, transfer_prover)
have other: "poly_rel
(m (times_poly_i ff_ops (power_poly_f_mod_i ff_ops m (m (times_poly_i ff_ops f f)) q) f))
(power_poly_f_mod m' (f' * f' mod m') q * f' mod m')"
by (rule m, rule poly_rel_times[unfolded rel_fun_def, rule_format, OF rec f])
show ?thesis unfolding power_poly_f_mod_i.simps[of _ _ _ n] Let_def
power_poly_f_mod_binary[of _ _ n] div split n if_False using rec other by auto
qed
qed
qed
lemma berlekamp_mat_i[transfer_rule]: "(poly_rel ===> mat_rel R)
(berlekamp_mat_i p ff_ops) berlekamp_mat"
proof (intro rel_funI)
fix f f'
let ?ze = "arith_ops_record.zero ff_ops"
let ?on = "arith_ops_record.one ff_ops"
assume f[transfer_rule]: "poly_rel f f'"
have deg: "degree_i f = degree f'" by transfer_prover
{
fix i j
assume i: "i < degree f'" and j: "j < degree f'"
define cs where "cs = (λcs :: 'i list. cs @ replicate (degree f' - length cs) ?ze)"
define cs' where "cs' = (λcs :: 'a mod_ring poly. coeffs cs @ replicate (degree f' - length (coeffs cs)) 0)"
define poly where "poly = power_polys_i ff_ops
(power_poly_f_mod_i ff_ops (λv. mod_field_poly_i ff_ops v f) [?ze, ?on] (nat p)) f [?on]
(degree f')"
define poly' where "poly' = (power_polys (power_poly_f_mod f' [:0, 1:] (nat p)) f' 1 (degree f'))"
have *: "poly_rel (power_poly_f_mod_i ff_ops (λv. mod_field_poly_i ff_ops v f) [?ze, ?on] (nat p))
(power_poly_f_mod f' [:0, 1:] (nat p))"
by (rule power_poly_f_mod_i, transfer_prover, simp add: poly_rel_def one zero)
have [transfer_rule]: "poly_rel (poly ! i) (poly' ! i)"
unfolding poly_def poly'_def
by (rule power_polys_i[OF i f *], simp add: poly_rel_def one)
have *: "list_all2 R (cs (poly ! i)) (cs' (poly' ! i))"
unfolding cs_def cs'_def by transfer_prover
from list_all2_nthD[OF *[unfolded poly_rel_def], of j] j
have "R (cs (poly ! i) ! j) (cs' (poly' ! i) ! j)" unfolding cs_def by auto
hence "R
(mat_of_rows_list (degree f')
(map (λcs. cs @ replicate (degree f' - length cs) ?ze)
(power_polys_i ff_ops
(power_poly_f_mod_i ff_ops (λv. mod_field_poly_i ff_ops v f) [?ze, ?on] (nat p)) f [?on]
(degree f'))) $$
(i, j))
(mat_of_rows_list (degree f')
(map (λcs. coeffs cs @ replicate (degree f' - length (coeffs cs)) 0)
(power_polys (power_poly_f_mod f' [:0, 1:] (nat p)) f' 1 (degree f'))) $$
(i, j))"
unfolding mat_of_rows_list_def length_map length_power_polys_i power_polys_works
length_power_polys index_mat[OF i j] split
unfolding poly_def cs_def poly'_def cs'_def using i
by auto
} note main = this
show "mat_rel R (berlekamp_mat_i p ff_ops f) (berlekamp_mat f')"
unfolding berlekamp_mat_i_def berlekamp_mat_def Let_def nat_p[symmetric] deg
unfolding mat_rel_def
by (intro conjI allI impI, insert main, auto)
qed
lemma berlekamp_resulting_mat_i[transfer_rule]: "(poly_rel ===> mat_rel R)
(berlekamp_resulting_mat_i p ff_ops) berlekamp_resulting_mat"
proof (intro rel_funI)
fix f f'
assume "poly_rel f f'"
from berlekamp_mat_i[unfolded rel_fun_def, rule_format, OF this]
have bmi: "mat_rel R (berlekamp_mat_i p ff_ops f) (berlekamp_mat f')" .
show "mat_rel R (berlekamp_resulting_mat_i p ff_ops f) (berlekamp_resulting_mat f')"
unfolding berlekamp_resulting_mat_def Let_def berlekamp_resulting_mat_i_def
by (rule gauss_jordan_i[unfolded rel_fun_def, rule_format],
insert bmi, auto simp: mat_rel_def one intro!: minus[unfolded rel_fun_def, rule_format])
qed
lemma berlekamp_basis_i[transfer_rule]: "(poly_rel ===> list_all2 poly_rel)
(berlekamp_basis_i p ff_ops) berlekamp_basis"
unfolding berlekamp_basis_i_def[abs_def] berlekamp_basis_code[abs_def] o_def
by transfer_prover
lemma berlekamp_factorization_main_i[transfer_rule]:
"((=) ===> list_all2 poly_rel ===> list_all2 poly_rel ===> (=) ===> list_all2 poly_rel)
(berlekamp_factorization_main_i p ff_ops (arith_ops_record.zero ff_ops)
(arith_ops_record.one ff_ops))
berlekamp_factorization_main"
proof (intro rel_funI, clarify, goal_cases)
case (1 _ d xs xs' ys ys' _ n)
let ?ze = "arith_ops_record.zero ff_ops"
let ?on = "arith_ops_record.one ff_ops"
let ?of_int = "arith_ops_record.of_int ff_ops"
from 1(2) 1(1) show ?case
proof (induct ys ys' arbitrary: xs xs' n rule: list_all2_induct)
case (Cons y ys y' ys' xs xs' n)
note trans[transfer_rule] = Cons(1,2,4)
obtain clar0 clar1 clar2 where clarify: "⋀ s u. gcd_poly_i ff_ops u
(minus_poly_i ff_ops y
(if s = 0 then [] else [?of_int (int s)])) = clar0 s u"
"[0..<nat p] = clar1"
"[?on] = clar2" by auto
define facts where "facts = concat (map (λu. concat
(map (λs. if gcd_poly_i ff_ops u
(minus_poly_i ff_ops y (if s = 0 then [] else [?of_int (int s)])) ≠
[?on]
then [gcd_poly_i ff_ops u
(minus_poly_i ff_ops y (if s = 0 then [] else [?of_int (int s)]))]
else [])
[0..<nat p])) xs)"
define Facts where "Facts = [w←concat
(map (λu. map (λs. gcd_poly_i ff_ops u
(minus_poly_i ff_ops y
(if s = 0 then [] else [?of_int (int s)])))
[0..<nat p])
xs) . w ≠ [?on]]"
have Facts: "Facts = facts"
unfolding Facts_def facts_def clarify
proof (induct xs)
case (Cons x xs)
show ?case by (simp add: Cons, induct clar1, auto)
qed simp
define facts' where "facts' = concat
(map (λu. concat
(map (λx. if gcd u (y' - [:of_nat x:]) ≠ 1
then [gcd u (y' - [:of_int (int x):])] else [])
[0..<nat p]))
xs')"
have id: "⋀ x. of_int (int x) = of_nat x" "[?on] = one_poly_i ff_ops"
by (auto simp: one_poly_i_def)
have facts[transfer_rule]: "list_all2 poly_rel facts facts'"
unfolding facts_def facts'_def
apply (rule concat_transfer[unfolded rel_fun_def, rule_format])
apply (rule list.map_transfer[unfolded rel_fun_def, rule_format, OF _ trans(3)])
apply (rule concat_transfer[unfolded rel_fun_def, rule_format])
apply (rule list_all2_map_map)
proof (unfold id)
fix f f' x
assume [transfer_rule]: "poly_rel f f'" and x: "x ∈ set [0..<nat p]"
hence *: "0 ≤ int x" "int x < p" by auto
from of_int[OF this] have rel[transfer_rule]: "R (?of_int (int x)) (of_nat x)" by auto
{
assume "0 < x"
with * have *: "0 < int x" "int x < p" by auto
have "(of_nat x :: 'a mod_ring) = of_int (int x)" by simp
also have "… ≠ 0" unfolding of_int_of_int_mod_ring using * unfolding p
by (transfer', auto)
}
with rel have [transfer_rule]: "poly_rel (if x = 0 then [] else [?of_int (int x)]) [:of_nat x:]"
unfolding poly_rel_def by (auto simp add: cCons_def p)
show "list_all2 poly_rel
(if gcd_poly_i ff_ops f (minus_poly_i ff_ops y (if x = 0 then [] else [?of_int (int x)])) ≠ one_poly_i ff_ops
then [gcd_poly_i ff_ops f (minus_poly_i ff_ops y (if x = 0 then [] else [?of_int (int x)]))]
else [])
(if gcd f' (y' - [:of_nat x:]) ≠ 1 then [gcd f' (y' - [:of_nat x:])] else [])"
by transfer_prover
qed
have id1: "berlekamp_factorization_main_i p ff_ops ?ze ?on d xs (y # ys) n = (
if y = [?on] then berlekamp_factorization_main_i p ff_ops ?ze ?on d xs ys n else
if length xs = n then xs else
(let fac = facts;
(lin, nonlin) = List.partition (λq. degree_i q = d) fac
in lin @ berlekamp_factorization_main_i p ff_ops ?ze ?on d nonlin ys (n - length lin)))"
unfolding berlekamp_factorization_main_i.simps Facts[symmetric]
by (simp add: o_def Facts_def Let_def)
have id2: "berlekamp_factorization_main d xs' (y' # ys') n = (
if y' = 1 then berlekamp_factorization_main d xs' ys' n
else if length xs' = n then xs' else
(let fac = facts';
(lin, nonlin) = List.partition (λq. degree q = d) fac
in lin @ berlekamp_factorization_main d nonlin ys' (n - length lin)))"
by (simp add: o_def facts'_def nat_p)
have len: "length xs = length xs'" by transfer_prover
have id3: "(y = [?on]) = (y' = 1)"
by (transfer_prover_start, transfer_step+, simp add: one_poly_i_def finite_field_ops_int_def)
show ?case
proof (cases "y' = 1")
case True
hence id4: "(y' = 1) = True" by simp
show ?thesis unfolding id1 id2 id3 id4 if_True
by (rule Cons(3), transfer_prover)
next
case False
hence id4: "(y' = 1) = False" by simp
note id1 = id1[unfolded id3 id4 if_False]
note id2 = id2[unfolded id4 if_False]
show ?thesis
proof (cases "length xs' = n")
case True
thus ?thesis unfolding id1 id2 Let_def len using trans by simp
next
case False
hence id: "(length xs' = n) = False" by simp
have id': "length [q←facts . degree_i q = d] = length [q←facts'. degree q = d]"
by transfer_prover
have [transfer_rule]: "list_all2 poly_rel (berlekamp_factorization_main_i p ff_ops ?ze ?on d [x←facts . degree_i x ≠ d] ys
(n - length [q←facts . degree_i q = d]))
(berlekamp_factorization_main d [x←facts' . degree x ≠ d] ys'
(n - length [q←facts' . degree q = d]))"
unfolding id'
by (rule Cons(3), transfer_prover)
show ?thesis unfolding id1 id2 Let_def len id if_False
unfolding partition_filter_conv o_def split by transfer_prover
qed
qed
qed simp
qed
lemma berlekamp_monic_factorization_i[transfer_rule]:
"((=) ===> poly_rel ===> list_all2 poly_rel)
(berlekamp_monic_factorization_i p ff_ops) berlekamp_monic_factorization"
unfolding berlekamp_monic_factorization_i_def[abs_def] berlekamp_monic_factorization_def[abs_def] Let_def
by transfer_prover
lemma dist_degree_factorize_main_i:
"poly_rel F f ⟹ poly_rel G g ⟹ list_all2 (rel_prod (=) poly_rel) Res res
⟹ list_all2 (rel_prod (=) poly_rel)
(dist_degree_factorize_main_i p ff_ops
(arith_ops_record.zero ff_ops) (arith_ops_record.one ff_ops) (degree_i F) F G d Res)
(dist_degree_factorize_main f g d res)"
proof (induct f g d res arbitrary: F G Res rule: dist_degree_factorize_main.induct)
case (1 v w d res V W Res)
let ?ze = "arith_ops_record.zero ff_ops"
let ?on = "arith_ops_record.one ff_ops"
note simp = dist_degree_factorize_main.simps[of v w d]
dist_degree_factorize_main_i.simps[of p ff_ops ?ze ?on "degree_i V" V W d]
have v[transfer_rule]: "poly_rel V v" by (rule 1)
have w[transfer_rule]: "poly_rel W w" by (rule 1)
have res[transfer_rule]: "list_all2 (rel_prod (=) poly_rel) Res res" by (rule 1)
have [transfer_rule]: "poly_rel [?on] 1"
by (simp add: one poly_rel_def)
have id1: "(V = [?on]) = (v = 1)" unfolding finite_field_ops_int_def by transfer_prover
have id2: "degree_i V = degree v" by transfer_prover
note simp = simp[unfolded id1 id2]
note IH = 1(1,2)
show ?case
proof (cases "v = 1")
case True
with res show ?thesis unfolding id2 simp by simp
next
case False
with id1 have "(v = 1) = False" by auto
note simp = simp[unfolded this if_False]
note IH = IH[OF False]
show ?thesis
proof (cases "degree v < d + d")
case True
thus ?thesis unfolding id2 simp using res v by auto
next
case False
hence "(degree v < d + d) = False" by auto
note simp = simp[unfolded this if_False]
let ?P = "power_poly_f_mod_i ff_ops (λf. mod_field_poly_i ff_ops f V) W (nat p)"
let ?G = "gcd_poly_i ff_ops (minus_poly_i ff_ops ?P [?ze, ?on]) V"
let ?g = "gcd (w ^ CARD('a) mod v - monom 1 1) v"
define G where "G = ?G"
define g where "g = ?g"
note simp = simp[unfolded Let_def, folded G_def g_def]
note IH = IH[OF False refl refl refl]
have [transfer_rule]: "poly_rel [?ze,?on] (monom 1 1)" unfolding poly_rel_def
by (auto simp: coeffs_monom one zero)
have id: "w ^ CARD('a) mod v = power_poly_f_mod v w (nat p)"
unfolding power_poly_f_mod_def by (simp add: p)
have P[transfer_rule]: "poly_rel ?P (w ^ CARD('a) mod v)" unfolding id
by (rule power_poly_f_mod_i[OF _ w], transfer_prover)
have g[transfer_rule]: "poly_rel G g" unfolding G_def g_def by transfer_prover
have id3: "(G = [?on]) = (g = 1)" by transfer_prover
note simp = simp[unfolded id3]
show ?thesis
proof (cases "g = 1")
case True
from IH(1)[OF this[unfolded g_def] v P res] True
show ?thesis unfolding id2 simp by simp
next
case False
have vg: "poly_rel (div_field_poly_i ff_ops V G) (v div g)" by transfer_prover
have "poly_rel (mod_field_poly_i ff_ops ?P
(div_field_poly_i ff_ops V G)) (w ^ CARD('a) mod v mod (v div g))" by transfer_prover
note IH = IH(2)[OF False[unfolded g_def] refl vg[unfolded G_def g_def] this[unfolded G_def g_def],
folded g_def G_def]
have "list_all2 (rel_prod (=) poly_rel) ((Suc d, G) # Res) ((Suc d, g) # res)"
using g res by auto
note IH = IH[OF this]
from False have "(g = 1) = False" by simp
note simp = simp[unfolded this if_False]
show ?thesis unfolding id2 simp using IH by simp
qed
qed
qed
qed
lemma distinct_degree_factorization_i[transfer_rule]: "(poly_rel ===> list_all2 (rel_prod (=) poly_rel))
(distinct_degree_factorization_i p ff_ops) distinct_degree_factorization"
proof
fix F f
assume f[transfer_rule]: "poly_rel F f"
have id: "(degree_i F = 1) = (degree f = 1)" by transfer_prover
note d = distinct_degree_factorization_i_def distinct_degree_factorization_def
let ?ze = "arith_ops_record.zero ff_ops"
let ?on = "arith_ops_record.one ff_ops"
show "list_all2 (rel_prod (=) poly_rel) (distinct_degree_factorization_i p ff_ops F)
(distinct_degree_factorization f)"
proof (cases "degree f = 1")
case True
with id f show ?thesis unfolding d by auto
next
case False
from False id have "?thesis = (list_all2 (rel_prod (=) poly_rel)
(dist_degree_factorize_main_i p ff_ops ?ze ?on (degree_i F) F [?ze, ?on] 0 [])
(dist_degree_factorize_main f (monom 1 1) 0 []))" unfolding d Let_def by simp
also have …
by (rule dist_degree_factorize_main_i[OF f], auto simp: poly_rel_def
coeffs_monom one zero)
finally show ?thesis .
qed
qed
lemma finite_field_factorization_i[transfer_rule]:
"(poly_rel ===> rel_prod R (list_all2 poly_rel))
(finite_field_factorization_i p ff_ops) finite_field_factorization"
unfolding finite_field_factorization_i_def finite_field_factorization_def Let_def lead_coeff_i_def'
by transfer_prover
text ‹Since the implementation is sound, we can now combine it with the soundness result
of the finite field factorization.›
lemma finite_field_i_sound:
assumes f': "f' = of_int_poly_i ff_ops (Mp f)"
and berl_i: "finite_field_factorization_i p ff_ops f' = (c',fs')"
and sq: "square_free_m f"
and fs: "fs = map (to_int_poly_i ff_ops) fs'"
and c: "c = arith_ops_record.to_int ff_ops c'"
shows "unique_factorization_m f (c, mset fs)
∧ c ∈ {0 ..< p}
∧ (∀ fi ∈ set fs. set (coeffs fi) ⊆ {0 ..< p})"
proof -
define f'' :: "'a mod_ring poly" where "f'' = of_int_poly (Mp f)"
have rel_f[transfer_rule]: "poly_rel f' f''"
by (rule poly_rel_of_int_poly[OF f'], simp add: f''_def)
interpret pff: idom_ops "poly_ops ff_ops" poly_rel
by (rule idom_ops_poly)
obtain c'' fs'' where berl: "finite_field_factorization f'' = (c'',fs'')" by force
from rel_funD[OF finite_field_factorization_i rel_f, unfolded rel_prod_conv assms(2) split berl]
have rel[transfer_rule]: "R c' c''" "list_all2 poly_rel fs' fs''" by auto
from to_int[OF rel(1)] have cc': "c = to_int_mod_ring c''" unfolding c by simp
have c: "c ∈ {0 ..< p}" unfolding cc'
by (metis Divides.pos_mod_bound Divides.pos_mod_sign M_to_int_mod_ring atLeastLessThan_iff
gr_implies_not_zero nat_le_0 nat_p not_le poly_mod.M_def zero_less_card_finite)
{
fix f
assume "f ∈ set fs'"
with rel(2) obtain f' where "poly_rel f f'" unfolding list_all2_conv_all_nth set_conv_nth
by auto
hence "is_poly ff_ops f" using fun_cong[OF Domainp_is_poly, of f]
unfolding Domainp_iff[abs_def] by auto
}
hence fs': "Ball (set fs') (is_poly ff_ops)" by auto
define mon :: "'a mod_ring poly ⇒ bool" where "mon = monic"
have [transfer_rule]: "(poly_rel ===> (=)) (monic_i ff_ops) mon" unfolding mon_def
by (rule poly_rel_monic)
have len: "length fs' = length fs''" by transfer_prover
have fs': "fs = map to_int_poly fs''" unfolding fs
proof (rule nth_map_conv[OF len], intro allI impI)
fix i
assume i: "i < length fs'"
obtain f g where id: "fs' ! i = f" "fs'' ! i = g" by auto
from i rel(2)[unfolded list_all2_conv_all_nth[of _ fs' fs'']] id
have "poly_rel f g" by auto
from to_int_poly_i[OF this] have "to_int_poly_i ff_ops f = to_int_poly g" .
thus "to_int_poly_i ff_ops (fs' ! i) = to_int_poly (fs'' ! i)" unfolding id .
qed
have f: "f'' = of_int_poly f" unfolding poly_eq_iff f''_def
by (simp add: to_int_mod_ring_hom.injectivity to_int_mod_ring_of_int_M Mp_coeff)
have *: "unique_factorization_m f (c, mset fs)"
using finite_field_factorization_modulo_ring[OF f sq berl cc' fs'] by auto
have fs': "(∀fi∈set fs. set (coeffs fi) ⊆ {0..<p})" unfolding fs'
using range_to_int_mod_ring[where 'a = 'a]
by (auto simp: coeffs_to_int_poly p)
with c fs *
show ?thesis by blast
qed
end
definition finite_field_factorization_main :: "int ⇒ 'i arith_ops_record ⇒ int poly ⇒ int × int poly list" where
"finite_field_factorization_main p f_ops f ≡
let (c',fs') = finite_field_factorization_i p f_ops (of_int_poly_i f_ops (poly_mod.Mp p f))
in (arith_ops_record.to_int f_ops c', map (to_int_poly_i f_ops) fs')"
lemma(in prime_field_gen) finite_field_factorization_main:
assumes res: "finite_field_factorization_main p ff_ops f = (c,fs)"
and sq: "square_free_m f"
shows "unique_factorization_m f (c, mset fs)
∧ c ∈ {0 ..< p}
∧ (∀ fi ∈ set fs. set (coeffs fi) ⊆ {0 ..< p})"
proof -
obtain c' fs' where
res': "finite_field_factorization_i p ff_ops (of_int_poly_i ff_ops (Mp f)) = (c', fs')" by force
show ?thesis
by (rule finite_field_i_sound[OF refl res' sq],
insert res[unfolded finite_field_factorization_main_def res'], auto)
qed
definition finite_field_factorization_int :: "int ⇒ int poly ⇒ int × int poly list" where
"finite_field_factorization_int p = (
if p ≤ 65535
then finite_field_factorization_main p (finite_field_ops32 (uint32_of_int p))
else if p ≤ 4294967295
then finite_field_factorization_main p (finite_field_ops64 (uint64_of_int p))
else finite_field_factorization_main p (finite_field_ops_integer (integer_of_int p)))"
context poly_mod_prime begin
lemmas finite_field_factorization_main_integer = prime_field_gen.finite_field_factorization_main
[OF prime_field.prime_field_finite_field_ops_integer, unfolded prime_field_def mod_ring_locale_def,
unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemmas finite_field_factorization_main_uint32 = prime_field_gen.finite_field_factorization_main
[OF prime_field.prime_field_finite_field_ops32, unfolded prime_field_def mod_ring_locale_def,
unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemmas finite_field_factorization_main_uint64 = prime_field_gen.finite_field_factorization_main
[OF prime_field.prime_field_finite_field_ops64, unfolded prime_field_def mod_ring_locale_def,
unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemma finite_field_factorization_int:
assumes sq: "poly_mod.square_free_m p f"
and result: "finite_field_factorization_int p f = (c,fs)"
shows "poly_mod.unique_factorization_m p f (c, mset fs)
∧ c ∈ {0 ..< p}
∧ (∀ fi ∈ set fs. set (coeffs fi) ⊆ {0 ..< p})"
using finite_field_factorization_main_integer[OF _ sq, of c fs]
finite_field_factorization_main_uint32[OF _ _ sq, of c fs]
finite_field_factorization_main_uint64[OF _ _ sq, of c fs]
result[unfolded finite_field_factorization_int_def]
by (auto split: if_splits)
end
end
Theory Hensel_Lifting
section ‹Hensel Lifting›
subsection ‹Properties about Factors›
text ‹We define and prove properties of Hensel-lifting. Here, we show the result that
Hensel-lifting can lift a factorization mod $p$ to a factorization mod $p^n$.
For the lifting we have proofs for both versions, the original linear Hensel-lifting or
the quadratic approach from Zassenhaus.
Via the linear version, we also show a uniqueness result, however only in the
binary case, i.e., where $f = g \cdot h$. Uniqueness of the general case will later be shown
in theory Berlekamp-Hensel by incorporating the factorization algorithm for finite fields algorithm.›
theory Hensel_Lifting
imports
"HOL-Computational_Algebra.Euclidean_Algorithm"
Poly_Mod_Finite_Field_Record_Based
Polynomial_Factorization.Square_Free_Factorization
begin
lemma uniqueness_poly_equality:
fixes f g :: "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"
assumes cop: "coprime f g"
and deg: "B = 0 ∨ degree B < degree f" "B' = 0 ∨ degree B' < degree f"
and f: "f ≠ 0" and eq: "A * f + B * g = A' * f + B' * g"
shows "A = A'" "B = B'"
proof -
from eq have *: "(A - A') * f = (B' - B) * g" by (simp add: field_simps)
hence "f dvd (B' - B) * g" unfolding dvd_def by (intro exI[of _ "A - A'"], auto simp: field_simps)
with cop[simplified] have dvd: "f dvd (B' - B)"
by (simp add: coprime_dvd_mult_right_iff ac_simps)
from divides_degree[OF this] have "degree f ≤ degree (B' - B) ∨ B = B'" by auto
with degree_diff_le_max[of B' B] deg
show "B = B'" by auto
with * f show "A = A'" by auto
qed
lemmas (in poly_mod_prime_type) uniqueness_poly_equality =
uniqueness_poly_equality[where 'a="'a mod_ring", untransferred]
lemmas (in poly_mod_prime) uniqueness_poly_equality = poly_mod_prime_type.uniqueness_poly_equality
[unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemma pseudo_divmod_main_list_1_is_divmod_poly_one_main_list:
"pseudo_divmod_main_list (1 :: 'a :: comm_ring_1) q f g n = divmod_poly_one_main_list q f g n"
by (induct n arbitrary: q f g, auto simp: Let_def)
lemma pdivmod_monic_pseudo_divmod: assumes g: "monic g" shows "pdivmod_monic f g = pseudo_divmod f g"
proof -
from g have id: "(coeffs g = []) = False" by auto
from g have mon: "hd (rev (coeffs g)) = 1" by (metis coeffs_eq_Nil hd_rev id last_coeffs_eq_coeff_degree)
show ?thesis
unfolding pseudo_divmod_impl pseudo_divmod_list_def id if_False pdivmod_monic_def Let_def mon
pseudo_divmod_main_list_1_is_divmod_poly_one_main_list by (auto split: prod.splits)
qed
lemma pdivmod_monic: assumes g: "monic g" and res: "pdivmod_monic f g = (q, r)"
shows "f = g * q + r" "r = 0 ∨ degree r < degree g"
proof -
from g have g0: "g ≠ 0" by auto
from pseudo_divmod[OF g0 res[unfolded pdivmod_monic_pseudo_divmod[OF g]], unfolded g]
show "f = g * q + r" "r = 0 ∨ degree r < degree g" by auto
qed
definition dupe_monic :: "'a :: comm_ring_1 poly ⇒ 'a poly ⇒ 'a poly ⇒ 'a poly ⇒ 'a poly ⇒
'a poly * 'a poly" where
"dupe_monic D H S T U = (case pdivmod_monic (T * U) D of (q,r) ⇒
(S * U + H * q, r))"
lemma dupe_monic: assumes 1: "D*S + H*T = 1"
and mon: "monic D"
and dupe: "dupe_monic D H S T U = (A,B)"
shows "A * D + B * H = U" "B = 0 ∨ degree B < degree D"
proof -
obtain Q R where div: "pdivmod_monic ((T * U)) D = (Q,R)" by force
from dupe[unfolded dupe_monic_def div split]
have A: "A = (S * U + H * Q)" and B: "B = R" by auto
from pdivmod_monic[OF mon div] have TU: "T * U = D * Q + R" and
deg: "R = 0 ∨ degree R < degree D" by auto
hence R: "R = T * U - D * Q" by simp
have "A * D + B * H = (D * S + H * T) * U" unfolding A B R by (simp add: field_simps)
also have "… = U" unfolding 1 by simp
finally show eq: "A * D + B * H = U" .
show "B = 0 ∨ degree B < degree D" using deg unfolding B .
qed
lemma dupe_monic_unique: fixes D :: "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"
assumes 1: "D*S + H*T = 1"
and mon: "monic D"
and dupe: "dupe_monic D H S T U = (A,B)"
and cop: "coprime D H"
and other: "A' * D + B' * H = U" "B' = 0 ∨ degree B' < degree D"
shows "A' = A" "B' = B"
proof -
from dupe_monic[OF 1 mon dupe] have one: "A * D + B * H = U" "B = 0 ∨ degree B < degree D" by auto
from mon have D0: "D ≠ 0" by auto
from uniqueness_poly_equality[OF cop one(2) other(2) D0, of A A', unfolded other, OF one(1)]
show "A' = A" "B' = B" by auto
qed
context ring_ops
begin
lemma poly_rel_dupe_monic_i: assumes mon: "monic D"
and rel: "poly_rel d D" "poly_rel h H" "poly_rel s S" "poly_rel t T" "poly_rel u U"
shows "rel_prod poly_rel poly_rel (dupe_monic_i ops d h s t u) (dupe_monic D H S T U)"
proof -
note defs = dupe_monic_i_def dupe_monic_def
note [transfer_rule] = rel
have [transfer_rule]: "rel_prod poly_rel poly_rel
(pdivmod_monic_i ops (times_poly_i ops t u) d)
(pdivmod_monic (T * U) D)"
by (rule poly_rel_pdivmod_monic[OF mon], transfer_prover+)
show ?thesis unfolding defs by transfer_prover
qed
end
context mod_ring_gen
begin
lemma monic_of_int_poly: "monic D ⟹ monic (of_int_poly (Mp D) :: 'a mod_ring poly)"
using Mp_f_representative Mp_to_int_poly monic_Mp by auto
lemma dupe_monic_i: assumes dupe_i: "dupe_monic_i ff_ops d h s t u = (a,b)"
and 1: "D*S + H*T =m 1"
and mon: "monic D"
and A: "A = to_int_poly_i ff_ops a"
and B: "B = to_int_poly_i ff_ops b"
and d: "Mp_rel_i d D"
and h: "Mp_rel_i h H"
and s: "Mp_rel_i s S"
and t: "Mp_rel_i t T"
and u: "Mp_rel_i u U"
shows
"A * D + B * H =m U"
"B = 0 ∨ degree B < degree D"
"Mp_rel_i a A"
"Mp_rel_i b B"
proof -
let ?I = "λ f. of_int_poly (Mp f) :: 'a mod_ring poly"
let ?i = "to_int_poly_i ff_ops"
note dd = Mp_rel_iD[OF d]
note hh = Mp_rel_iD[OF h]
note ss = Mp_rel_iD[OF s]
note tt = Mp_rel_iD[OF t]
note uu = Mp_rel_iD[OF u]
obtain A' B' where dupe: "dupe_monic (?I D) (?I H) (?I S) (?I T) (?I U) = (A',B')" by force
from poly_rel_dupe_monic_i[OF monic_of_int_poly[OF mon] dd(1) hh(1) ss(1) tt(1) uu(1), unfolded dupe_i dupe]
have a: "poly_rel a A'" and b: "poly_rel b B'" by auto
show aa: "Mp_rel_i a A" by (rule Mp_rel_iI'[OF a, folded A])
show bb: "Mp_rel_i b B" by (rule Mp_rel_iI'[OF b, folded B])
note Aa = Mp_rel_iD[OF aa]
note Bb = Mp_rel_iD[OF bb]
from poly_rel_inj[OF a Aa(1)] A have A: "A' = ?I A" by simp
from poly_rel_inj[OF b Bb(1)] B have B: "B' = ?I B" by simp
note Mp = dd(2) hh(2) ss(2) tt(2) uu(2)
note [transfer_rule] = Mp
have "(=) (D * S + H * T =m 1) (?I D * ?I S + ?I H * ?I T = 1)" by transfer_prover
with 1 have 11: "?I D * ?I S + ?I H * ?I T = 1" by simp
from dupe_monic[OF 11 monic_of_int_poly[OF mon] dupe, unfolded A B]
have res: "?I A * ?I D + ?I B * ?I H = ?I U" "?I B = 0 ∨ degree (?I B) < degree (?I D)" by auto
note [transfer_rule] = Aa(2) Bb(2)
have "(=) (A * D + B * H =m U) (?I A * ?I D + ?I B * ?I H = ?I U)"
"(=) (B =m 0 ∨ degree_m B < degree_m D) (?I B = 0 ∨ degree (?I B) < degree (?I D))" by transfer_prover+
with res have *: "A * D + B * H =m U" "B =m 0 ∨ degree_m B < degree_m D" by auto
show "A * D + B * H =m U" by fact
have B: "Mp B = B" using Mp_rel_i_Mp_to_int_poly_i assms(5) bb by blast
from *(2) show "B = 0 ∨ degree B < degree D" unfolding B using degree_m_le[of D] by auto
qed
lemma Mp_rel_i_of_int_poly_i: assumes "Mp F = F"
shows "Mp_rel_i (of_int_poly_i ff_ops F) F"
by (metis Mp_f_representative Mp_rel_iI' assms poly_rel_of_int_poly to_int_poly_i)
lemma dupe_monic_i_int: assumes dupe_i: "dupe_monic_i_int ff_ops D H S T U = (A,B)"
and 1: "D*S + H*T =m 1"
and mon: "monic D"
and norm: "Mp D = D" "Mp H = H" "Mp S = S" "Mp T = T" "Mp U = U"
shows
"A * D + B * H =m U"
"B = 0 ∨ degree B < degree D"
"Mp A = A"
"Mp B = B"
proof -
let ?oi = "of_int_poly_i ff_ops"
let ?ti = "to_int_poly_i ff_ops"
note rel = norm[THEN Mp_rel_i_of_int_poly_i]
obtain a b where dupe: "dupe_monic_i ff_ops (?oi D) (?oi H) (?oi S) (?oi T) (?oi U) = (a,b)" by force
from dupe_i[unfolded dupe_monic_i_int_def this Let_def] have AB: "A = ?ti a" "B = ?ti b" by auto
from dupe_monic_i[OF dupe 1 mon AB rel] Mp_rel_i_Mp_to_int_poly_i
show "A * D + B * H =m U"
"B = 0 ∨ degree B < degree D"
"Mp A = A"
"Mp B = B"
unfolding AB by auto
qed
end
definition dupe_monic_dynamic
:: "int ⇒ int poly ⇒ int poly ⇒ int poly ⇒ int poly ⇒ int poly ⇒ int poly × int poly" where
"dupe_monic_dynamic p = (
if p ≤ 65535
then dupe_monic_i_int (finite_field_ops32 (uint32_of_int p))
else if p ≤ 4294967295
then dupe_monic_i_int (finite_field_ops64 (uint64_of_int p))
else dupe_monic_i_int (finite_field_ops_integer (integer_of_int p)))"
context poly_mod_2
begin
lemma dupe_monic_i_int_finite_field_ops_integer: assumes
dupe_i: "dupe_monic_i_int (finite_field_ops_integer (integer_of_int m)) D H S T U = (A,B)"
and 1: "D*S + H*T =m 1"
and mon: "monic D"
and norm: "Mp D = D" "Mp H = H" "Mp S = S" "Mp T = T" "Mp U = U"
shows
"A * D + B * H =m U"
"B = 0 ∨ degree B < degree D"
"Mp A = A"
"Mp B = B"
using m1 mod_ring_gen.dupe_monic_i_int[OF
mod_ring_locale.mod_ring_finite_field_ops_integer[unfolded mod_ring_locale_def],
internalize_sort "'a :: nontriv", OF type_to_set, unfolded remove_duplicate_premise,
cancel_type_definition, OF _ assms] by auto
lemma dupe_monic_i_int_finite_field_ops32: assumes
m: "m ≤ 65535"
and dupe_i: "dupe_monic_i_int (finite_field_ops32 (uint32_of_int m)) D H S T U = (A,B)"
and 1: "D*S + H*T =m 1"
and mon: "monic D"
and norm: "Mp D = D" "Mp H = H" "Mp S = S" "Mp T = T" "Mp U = U"
shows
"A * D + B * H =m U"
"B = 0 ∨ degree B < degree D"
"Mp A = A"
"Mp B = B"
using m1 mod_ring_gen.dupe_monic_i_int[OF
mod_ring_locale.mod_ring_finite_field_ops32[unfolded mod_ring_locale_def],
internalize_sort "'a :: nontriv", OF type_to_set, unfolded remove_duplicate_premise,
cancel_type_definition, OF _ assms] by auto
lemma dupe_monic_i_int_finite_field_ops64: assumes
m: "m ≤ 4294967295"
and dupe_i: "dupe_monic_i_int (finite_field_ops64 (uint64_of_int m)) D H S T U = (A,B)"
and 1: "D*S + H*T =m 1"
and mon: "monic D"
and norm: "Mp D = D" "Mp H = H" "Mp S = S" "Mp T = T" "Mp U = U"
shows
"A * D + B * H =m U"
"B = 0 ∨ degree B < degree D"
"Mp A = A"
"Mp B = B"
using m1 mod_ring_gen.dupe_monic_i_int[OF
mod_ring_locale.mod_ring_finite_field_ops64[unfolded mod_ring_locale_def],
internalize_sort "'a :: nontriv", OF type_to_set, unfolded remove_duplicate_premise,
cancel_type_definition, OF _ assms] by auto
lemma dupe_monic_dynamic: assumes dupe: "dupe_monic_dynamic m D H S T U = (A,B)"
and 1: "D*S + H*T =m 1"
and mon: "monic D"
and norm: "Mp D = D" "Mp H = H" "Mp S = S" "Mp T = T" "Mp U = U"
shows
"A * D + B * H =m U"
"B = 0 ∨ degree B < degree D"
"Mp A = A"
"Mp B = B"
using dupe
dupe_monic_i_int_finite_field_ops32[OF _ _ 1 mon norm, of A B]
dupe_monic_i_int_finite_field_ops64[OF _ _ 1 mon norm, of A B]
dupe_monic_i_int_finite_field_ops_integer[OF _ 1 mon norm, of A B]
unfolding dupe_monic_dynamic_def by (auto split: if_splits)
end
context poly_mod
begin
definition dupe_monic_int :: "int poly ⇒ int poly ⇒ int poly ⇒ int poly ⇒ int poly ⇒
int poly * int poly" where
"dupe_monic_int D H S T U = (case pdivmod_monic (Mp (T * U)) D of (q,r) ⇒
(Mp (S * U + H * q), Mp r))"
end
declare poly_mod.dupe_monic_int_def[code]
text ‹Old direct proof on int poly.
It does not permit to change implementation.
This proof is still present, since we did not export the uniqueness part
from the type-based uniqueness result @{thm dupe_monic_unique} via the various relations.›
lemma (in poly_mod_2) dupe_monic_int: assumes 1: "D*S + H*T =m 1"
and mon: "monic D"
and dupe: "dupe_monic_int D H S T U = (A,B)"
shows "A * D + B * H =m U" "B = 0 ∨ degree B < degree D" "Mp A = A" "Mp B = B"
"coprime_m D H ⟹ A' * D + B' * H =m U ⟹ B' = 0 ∨ degree B' < degree D ⟹ Mp D = D
⟹ Mp A' = A' ⟹ Mp B' = B' ⟹ prime m
⟹ A' = A ∧ B' = B"
proof -
obtain Q R where div: "pdivmod_monic (Mp (T * U)) D = (Q,R)" by force
from dupe[unfolded dupe_monic_int_def div split]
have A: "A = Mp (S * U + H * Q)" and B: "B = Mp R" by auto
from pdivmod_monic[OF mon div] have TU: "Mp (T * U) = D * Q + R" and
deg: "R = 0 ∨ degree R < degree D" by auto
hence "Mp R = Mp (Mp (T * U) - D * Q)" by simp
also have "… = Mp (T * U - Mp (Mp (Mp D * Q)))" unfolding Mp_Mp unfolding minus_Mp
using minus_Mp mult_Mp by metis
also have "… = Mp (T * U - D * Q)" by simp
finally have r: "Mp R = Mp (T * U - D * Q)" by simp
have "Mp (A * D + B * H) = Mp (Mp (A * D) + Mp (B * H))" by simp
also have "Mp (A * D) = Mp ((S * U + H * Q) * D)" unfolding A by simp
also have "Mp (B * H) = Mp (Mp R * Mp H)" unfolding B by simp
also have "… = Mp ((T * U - D * Q) * H)" unfolding r by simp
also have "Mp (Mp ((S * U + H * Q) * D) + Mp ((T * U - D * Q) * H)) =
Mp ((S * U + H * Q) * D + (T * U - D * Q) * H)" by simp
also have "(S * U + H * Q) * D + (T * U - D * Q) * H = (D * S + H * T) * U"
by (simp add: field_simps)
also have "Mp … = Mp (Mp (D * S + H * T) * U)" by simp
also have "Mp (D * S + H * T) = 1" using 1 by simp
finally show eq: "A * D + B * H =m U" by simp
have id: "degree_m (Mp R) = degree_m R" by simp
have id': "degree D = degree_m D" using mon by simp
show degB: "B = 0 ∨ degree B < degree D" using deg unfolding B id id'
using degree_m_le[of R] by (cases "R = 0", auto)
show Mp: "Mp A = A" "Mp B = B" unfolding A B by auto
assume another: "A' * D + B' * H =m U" and degB': "B' = 0 ∨ degree B' < degree D"
and norm: "Mp A' = A'" "Mp B' = B'" and cop: "coprime_m D H" and D: "Mp D = D"
and prime: "prime m"
from degB Mp D have degB: "B =m 0 ∨ degree_m B < degree_m D" by auto
from degB' Mp D norm have degB': "B' =m 0 ∨ degree_m B' < degree_m D" by auto
from mon D have D0: "¬ (D =m 0)" by auto
from prime interpret poly_mod_prime m by unfold_locales
from another eq have "A' * D + B' * H =m A * D + B * H" by simp
from uniqueness_poly_equality[OF cop degB' degB D0 this]
show "A' = A ∧ B' = B" unfolding norm Mp by auto
qed
lemma coprime_bezout_coefficients:
assumes cop: "coprime f g"
and ext: "bezout_coefficients f g = (a, b)"
shows "a * f + b * g = 1"
using assms bezout_coefficients [of f g a b]
by simp
lemma (in poly_mod_prime_type) bezout_coefficients_mod_int: assumes f: "(F :: 'a mod_ring poly) = of_int_poly f"
and g: "(G :: 'a mod_ring poly) = of_int_poly g"
and cop: "coprime_m f g"
and fact: "bezout_coefficients F G = (A,B)"
and a: "a = to_int_poly A"
and b: "b = to_int_poly B"
shows "f * a + g * b =m 1"
proof -
have f[transfer_rule]: "MP_Rel f F" unfolding f MP_Rel_def by (simp add: Mp_f_representative)
have g[transfer_rule]: "MP_Rel g G" unfolding g MP_Rel_def by (simp add: Mp_f_representative)
have [transfer_rule]: "MP_Rel a A" unfolding a MP_Rel_def by (rule Mp_to_int_poly)
have [transfer_rule]: "MP_Rel b B" unfolding b MP_Rel_def by (rule Mp_to_int_poly)
from cop have "coprime F G" using coprime_MP_Rel[unfolded rel_fun_def] f g by auto
from coprime_bezout_coefficients [OF this fact]
have "A * F + B * G = 1" .
from this [untransferred]
show ?thesis by (simp add: ac_simps)
qed
definition bezout_coefficients_i :: "'i arith_ops_record ⇒ 'i list ⇒ 'i list ⇒ 'i list × 'i list" where
"bezout_coefficients_i ff_ops f g = fst (euclid_ext_poly_i ff_ops f g)"
definition euclid_ext_poly_mod_main :: "int ⇒ 'a arith_ops_record ⇒ int poly ⇒ int poly ⇒ int poly × int poly" where
"euclid_ext_poly_mod_main p ff_ops f g = (case bezout_coefficients_i ff_ops (of_int_poly_i ff_ops f) (of_int_poly_i ff_ops g) of
(a,b) ⇒ (to_int_poly_i ff_ops a, to_int_poly_i ff_ops b))"
definition euclid_ext_poly_dynamic :: "int ⇒ int poly ⇒ int poly ⇒ int poly × int poly" where
"euclid_ext_poly_dynamic p = (
if p ≤ 65535
then euclid_ext_poly_mod_main p (finite_field_ops32 (uint32_of_int p))
else if p ≤ 4294967295
then euclid_ext_poly_mod_main p (finite_field_ops64 (uint64_of_int p))
else euclid_ext_poly_mod_main p (finite_field_ops_integer (integer_of_int p)))"
context prime_field_gen
begin
lemma bezout_coefficients_i[transfer_rule]:
"(poly_rel ===> poly_rel ===> rel_prod poly_rel poly_rel)
(bezout_coefficients_i ff_ops) bezout_coefficients"
unfolding bezout_coefficients_i_def bezout_coefficients_def
by transfer_prover
lemma bezout_coefficients_i_sound: assumes f: "f' = of_int_poly_i ff_ops f" "Mp f = f"
and g: "g' = of_int_poly_i ff_ops g" "Mp g = g"
and cop: "coprime_m f g"
and res: "bezout_coefficients_i ff_ops f' g' = (a',b')"
and a: "a = to_int_poly_i ff_ops a'"
and b: "b = to_int_poly_i ff_ops b'"
shows "f * a + g * b =m 1"
"Mp a = a" "Mp b = b"
proof -
from f have f': "f' = of_int_poly_i ff_ops (Mp f)" by simp
define f'' where "f'' ≡ of_int_poly (Mp f) :: 'a mod_ring poly"
have f'': "f'' = of_int_poly f" unfolding f''_def f by simp
have rel_f[transfer_rule]: "poly_rel f' f''"
by (rule poly_rel_of_int_poly[OF f'], simp add: f'' f)
from g have g': "g' = of_int_poly_i ff_ops (Mp g)" by simp
define g'' where "g'' ≡ of_int_poly (Mp g) :: 'a mod_ring poly"
have g'': "g'' = of_int_poly g" unfolding g''_def g by simp
have rel_g[transfer_rule]: "poly_rel g' g''"
by (rule poly_rel_of_int_poly[OF g'], simp add: g'' g)
obtain a'' b'' where eucl: "bezout_coefficients f'' g'' = (a'',b'')" by force
from bezout_coefficients_i[unfolded rel_fun_def rel_prod_conv, rule_format, OF rel_f rel_g,
unfolded res split eucl]
have rel[transfer_rule]: "poly_rel a' a''" "poly_rel b' b''" by auto
with to_int_poly_i have a: "a = to_int_poly a''"
and b: "b = to_int_poly b''" unfolding a b by auto
from bezout_coefficients_mod_int [OF f'' g'' cop eucl a b]
show "f * a + g * b =m 1" .
show "Mp a = a" "Mp b = b" unfolding a b by (auto simp: Mp_to_int_poly)
qed
lemma euclid_ext_poly_mod_main: assumes cop: "coprime_m f g"
and f: "Mp f = f" and g: "Mp g = g"
and res: "euclid_ext_poly_mod_main m ff_ops f g = (a,b)"
shows "f * a + g * b =m 1"
"Mp a = a" "Mp b = b"
proof -
obtain a' b' where res': "bezout_coefficients_i ff_ops (of_int_poly_i ff_ops f)
(of_int_poly_i ff_ops g) = (a', b')" by force
show "f * a + g * b =m 1"
"Mp a = a" "Mp b = b"
by (insert bezout_coefficients_i_sound[OF refl f refl g cop res']
res [unfolded euclid_ext_poly_mod_main_def res'], auto)
qed
end
context poly_mod_prime begin
lemmas euclid_ext_poly_mod_integer = prime_field_gen.euclid_ext_poly_mod_main
[OF prime_field.prime_field_finite_field_ops_integer,
unfolded prime_field_def mod_ring_locale_def poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemmas euclid_ext_poly_mod_uint32 = prime_field_gen.euclid_ext_poly_mod_main
[OF prime_field.prime_field_finite_field_ops32,
unfolded prime_field_def mod_ring_locale_def poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemmas euclid_ext_poly_mod_uint64 = prime_field_gen.euclid_ext_poly_mod_main[OF prime_field.prime_field_finite_field_ops64,
unfolded prime_field_def mod_ring_locale_def poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemma euclid_ext_poly_dynamic:
assumes cop: "coprime_m f g" and f: "Mp f = f" and g: "Mp g = g"
and res: "euclid_ext_poly_dynamic p f g = (a,b)"
shows "f * a + g * b =m 1"
"Mp a = a" "Mp b = b"
using euclid_ext_poly_mod_integer[OF cop f g, of p a b]
euclid_ext_poly_mod_uint32[OF _ cop f g, of p a b]
euclid_ext_poly_mod_uint64[OF _ cop f g, of p a b]
res[unfolded euclid_ext_poly_dynamic_def] by (auto split: if_splits)
end
lemma range_sum_prod: assumes xy: "x ∈ {0..<q}" "(y :: int) ∈ {0..<p}"
shows "x + q * y ∈ {0..<p * q}"
proof -
{
fix x q :: int
have "x ∈ {0 ..< q} ⟷ 0 ≤ x ∧ x < q" by auto
} note id = this
from xy have 0: "0 ≤ x + q * y" by auto
have "x + q * y ≤ q - 1 + q * y" using xy by simp
also have "q * y ≤ q * (p - 1)" using xy by auto
finally have "x + q * y ≤ q - 1 + q * (p - 1)" by auto
also have "… = p * q - 1" by (simp add: field_simps)
finally show ?thesis using 0 by auto
qed
context
fixes C :: "int poly"
begin
context
fixes p :: int and S T D1 H1 :: "int poly"
begin
fun linear_hensel_main where
"linear_hensel_main (Suc 0) = (D1,H1)"
| "linear_hensel_main (Suc n) = (
let (D,H) = linear_hensel_main n;
q = p ^ n;
U = poly_mod.Mp p (sdiv_poly (C - D * H) q);
(A,B) = poly_mod.dupe_monic_int p D1 H1 S T U
in (D + smult q B, H + smult q A)) "
| "linear_hensel_main 0 = (D1,H1)"
lemma linear_hensel_main: assumes 1: "poly_mod.eq_m p (D1 * S + H1 * T) 1"
and equiv: "poly_mod.eq_m p (D1 * H1) C"
and monD1: "monic D1"
and normDH1: "poly_mod.Mp p D1 = D1" "poly_mod.Mp p H1 = H1"
and res: "linear_hensel_main n = (D,H)"
and n: "n ≠ 0"
and prime: "prime p"
and cop: "poly_mod.coprime_m p D1 H1"
shows "poly_mod.eq_m (p^n) (D * H) C
∧ monic D
∧ poly_mod.eq_m p D D1 ∧ poly_mod.eq_m p H H1
∧ poly_mod.Mp (p^n) D = D
∧ poly_mod.Mp (p^n) H = H ∧
(poly_mod.eq_m (p^n) (D' * H') C ⟶
poly_mod.eq_m p D' D1 ⟶
poly_mod.eq_m p H' H1 ⟶
poly_mod.Mp (p^n) D' = D' ⟶
poly_mod.Mp (p^n) H' = H' ⟶ monic D' ⟶ D' = D ∧ H' = H)
"
using res n
proof (induct n arbitrary: D H D' H')
case (Suc n D' H' D'' H'')
show ?case
proof (cases "n = 0")
case True
with Suc equiv monD1 normDH1 show ?thesis by auto
next
case False
hence n: "n ≠ 0" by auto
let ?q = "p^n"
let ?pq = "p * p^n"
from prime have p: "p > 1" using prime_gt_1_int by force
from n p have q: "?q > 1" by auto
from n p have pq: "?pq > 1" by (metis power_gt1_lemma)
interpret p: poly_mod_2 p using p unfolding poly_mod_2_def .
interpret q: poly_mod_2 ?q using q unfolding poly_mod_2_def .
interpret pq: poly_mod_2 ?pq using pq unfolding poly_mod_2_def .
obtain D H where rec: "linear_hensel_main n = (D,H)" by force
obtain V where V: "sdiv_poly (C - D * H) ?q = V" by force
obtain U where U: "p.Mp (sdiv_poly (C - D * H) ?q) = U" by auto
obtain A B where dupe: "p.dupe_monic_int D1 H1 S T U = (A,B)" by force
note IH = Suc(1)[OF rec n]
from IH
have CDH: "q.eq_m (D * H) C"
and monD: "monic D"
and p_eq: "p.eq_m D D1" "p.eq_m H H1"
and norm: "q.Mp D = D" "q.Mp H = H" by auto
from n obtain k where n: "n = Suc k" by (cases n, auto)
have qq: "?q * ?q = ?pq * p^k" unfolding n by simp
from Suc(2)[unfolded n linear_hensel_main.simps, folded n, unfolded rec split Let_def U dupe]
have D': "D' = D + smult ?q B" and H': "H' = H + smult ?q A" by auto
note dupe = p.dupe_monic_int[OF 1 monD1 dupe]
from CDH have "q.Mp C - q.Mp (D * H) = 0" by simp
hence "q.Mp (q.Mp C - q.Mp (D * H)) = 0" by simp
hence "q.Mp (C - D*H) = 0" by simp
from q.Mp_0_smult_sdiv_poly[OF this] have CDHq: "smult ?q (sdiv_poly (C - D * H) ?q) = C - D * H" .
have ADBHU: "p.eq_m (A * D + B * H) U" using p_eq dupe(1)
by (metis (mono_tags, lifting) p.mult_Mp(2) poly_mod.plus_Mp)
have "pq.Mp (D' * H') = pq.Mp ((D + smult ?q B) * (H + smult ?q A))"
unfolding D' H' by simp
also have "(D + smult ?q B) * (H + smult ?q A) = (D * H + smult ?q (A * D + B * H)) + smult (?q * ?q) (A * B)"
by (simp add: field_simps smult_distribs)
also have "pq.Mp … = pq.Mp (D * H + pq.Mp (smult ?q (A * D + B * H)) + pq.Mp (smult (?q * ?q) (A * B)))"
using pq.plus_Mp by metis
also have "pq.Mp (smult (?q * ?q) (A * B)) = 0" unfolding qq
by (metis pq.Mp_smult_m_0 smult_smult)
finally have DH': "pq.Mp (D' * H') = pq.Mp (D * H + pq.Mp (smult ?q (A * D + B * H)))" by simp
also have "pq.Mp (smult ?q (A * D + B * H)) = pq.Mp (smult ?q U)"
using p.Mp_lift_modulus[OF ADBHU, of ?q] by simp
also have "… = pq.Mp (C - D * H)"
unfolding arg_cong[OF CDHq, of pq.Mp, symmetric] U[symmetric] V
by (rule p.Mp_lift_modulus[of _ _ ?q], auto)
also have "pq.Mp (D * H + pq.Mp (C - D * H)) = pq.Mp C" by simp
finally have CDH: "pq.eq_m C (D' * H')" by simp
have deg: "degree D1 = degree D" using p_eq(1) monD1 monD
by (metis p.monic_degree_m)
have mon: "monic D'" unfolding D' using dupe(2) monD unfolding deg by (rule monic_smult_add_small)
have normD': "pq.Mp D' = D'"
unfolding D' pq.Mp_ident_iff poly_mod.Mp_coeff plus_poly.rep_eq coeff_smult
proof
fix i
from norm(1) dupe(4) have "coeff D i ∈ {0..<?q}" "coeff B i ∈ {0..<p}"
unfolding p.Mp_ident_iff q.Mp_ident_iff by auto
thus "coeff D i + ?q * coeff B i ∈ {0..< ?pq}" by (rule range_sum_prod)
qed
have normH': "pq.Mp H' = H'"
unfolding H' pq.Mp_ident_iff poly_mod.Mp_coeff plus_poly.rep_eq coeff_smult
proof
fix i
from norm(2) dupe(3) have "coeff H i ∈ {0..<?q}" "coeff A i ∈ {0..<p}"
unfolding p.Mp_ident_iff q.Mp_ident_iff by auto
thus "coeff H i + ?q * coeff A i ∈ {0..< ?pq}" by (rule range_sum_prod)
qed
have eq: "p.eq_m D D'" "p.eq_m H H'" unfolding D' H' n
poly_eq_iff p.Mp_coeff p.M_def by (auto simp: field_simps)
with p_eq have eq: "p.eq_m D' D1" "p.eq_m H' H1" by auto
{
assume CDH'': "pq.eq_m C (D'' * H'')"
and DH1'': "p.eq_m D1 D''" "p.eq_m H1 H''"
and norm'': "pq.Mp D'' = D''" "pq.Mp H'' = H''"
and monD'': "monic D''"
from q.Dp_Mp_eq[of D''] obtain d B' where D'': "D'' = q.Mp d + smult ?q B'" by auto
from q.Dp_Mp_eq[of H''] obtain h A' where H'': "H'' = q.Mp h + smult ?q A'" by auto
{
fix A B
assume *: "pq.Mp (q.Mp A + smult ?q B) = q.Mp A + smult ?q B"
have "p.Mp B = B" unfolding p.Mp_ident_iff
proof
fix i
from arg_cong[OF *, of "λ f. coeff f i", unfolded pq.Mp_coeff pq.M_def]
have "coeff (q.Mp A + smult ?q B) i ∈ {0 ..< ?pq}" using "*" pq.Mp_ident_iff by blast
hence sum: "coeff (q.Mp A) i + ?q * coeff B i ∈ {0 ..< ?pq}" by auto
have "q.Mp (q.Mp A) = q.Mp A" by auto
from this[unfolded q.Mp_ident_iff] have A: "coeff (q.Mp A) i ∈ {0 ..< p^n}" by auto
{
assume "coeff B i < 0" hence "coeff B i ≤ -1" by auto
from mult_left_mono[OF this, of ?q] q.m1 have "?q * coeff B i ≤ -?q" by simp
with A sum have False by auto
} hence "coeff B i ≥ 0" by force
moreover
{
assume "coeff B i ≥ p"
from mult_left_mono[OF this, of ?q] q.m1 have "?q * coeff B i ≥ ?pq" by simp
with A sum have False by auto
} hence "coeff B i < p" by force
ultimately show "coeff B i ∈ {0 ..< p}" by auto
qed
} note norm_convert = this
from norm_convert[OF norm''(1)[unfolded D'']] have normB': "p.Mp B' = B'" .
from norm_convert[OF norm''(2)[unfolded H'']] have normA': "p.Mp A' = A'" .
let ?d = "q.Mp d"
let ?h = "q.Mp h"
{
assume lt: "degree ?d < degree B'"
hence eq: "degree D'' = degree B'" unfolding D'' using q.m1 p.m1
by (subst degree_add_eq_right, auto)
from lt have [simp]: "coeff ?d (degree B') = 0" by (rule coeff_eq_0)
from monD''[unfolded eq, unfolded D'', simplified] False q.m1 lt have False
by (metis mod_mult_self1_is_0 poly_mod.M_def q.M_1 zero_neq_one)
}
hence deg_dB': "degree ?d ≥ degree B'" by presburger
{
assume eq: "degree ?d = degree B'" and B': "B' ≠ 0"
let ?B = "coeff B' (degree B')"
from normB'[unfolded p.Mp_ident_iff, rule_format, of "degree B'"] B'
have "?B ∈ {0..<p} - {0}" by simp
hence bnds: "?B > 0" "?B < p" by auto
have degD'': "degree D'' ≤ degree ?d" unfolding D'' using eq by (simp add: degree_add_le)
have "?q * ?B ≥ 1 * 1" by (rule mult_mono, insert q.m1 bnds, auto)
moreover have "coeff D'' (degree ?d) = 1 + ?q * ?B" using monD''
unfolding D'' using eq
by (metis D'' coeff_smult monD'' plus_poly.rep_eq poly_mod.Dp_Mp_eq
poly_mod.degree_m_eq_monic poly_mod.plus_Mp(1)
q.Mp_smult_m_0 q.m1 q.monic_Mp q.plus_Mp(2))
ultimately have gt: "coeff D'' (degree ?d) > 1" by auto
hence "coeff D'' (degree ?d) ≠ 0" by auto
hence "degree D'' ≥ degree ?d" by (rule le_degree)
with degree_add_le_max[of ?d "smult ?q B'", folded D''] eq
have deg: "degree D'' = degree ?d" using degD'' by linarith
from gt[folded this] have "¬ monic D''" by auto
with monD'' have False by auto
}
with deg_dB' have deg_dB2: "B' = 0 ∨ degree B' < degree ?d" by fastforce
have d: "q.Mp D'' = ?d" unfolding D''
by (metis add.right_neutral poly_mod.Mp_smult_m_0 poly_mod.plus_Mp)
have h: "q.Mp H'' = ?h" unfolding H''
by (metis add.right_neutral poly_mod.Mp_smult_m_0 poly_mod.plus_Mp)
from CDH'' have "pq.Mp C = pq.Mp (D'' * H'')" by simp
from arg_cong[OF this, of q.Mp]
have "q.Mp C = q.Mp (D'' * H'')"
using p.m1 q.Mp_product_modulus by auto
also have "… = q.Mp (q.Mp D'' * q.Mp H'')" by simp
also have "… = q.Mp (?d * ?h)" unfolding d h by simp
finally have eqC: "q.eq_m (?d * ?h) C" by auto
have d1: "p.eq_m ?d D1" unfolding d[symmetric] using DH1''
using assms(4) n p.Mp_product_modulus p.m1 by auto
have h1: "p.eq_m ?h H1" unfolding h[symmetric] using DH1''
using assms(5) n p.Mp_product_modulus p.m1 by auto
have mond: "monic (q.Mp d)" using monD'' deg_dB2 unfolding D''
using d q.monic_Mp[OF monD''] by simp
from eqC d1 h1 mond IH[of "q.Mp d" "q.Mp h"] have IH: "?d = D" "?h = H" by auto
from deg_dB2[unfolded IH] have degB': "B' = 0 ∨ degree B' < degree D" by auto
from IH have D'': "D'' = D + smult ?q B'" and H'': "H'' = H + smult ?q A'"
unfolding D'' H'' by auto
have "pq.Mp (D'' * H'') = pq.Mp (D' * H')" using CDH'' CDH by simp
also have "pq.Mp (D'' * H'') = pq.Mp ((D + smult ?q B') * (H + smult ?q A'))"
unfolding D'' H'' by simp
also have "(D + smult ?q B') * (H + smult ?q A') = (D * H + smult ?q (A' * D + B' * H)) + smult (?q * ?q) (A' * B')"
by (simp add: field_simps smult_distribs)
also have "pq.Mp … = pq.Mp (D * H + pq.Mp (smult ?q (A' * D + B' * H)) + pq.Mp (smult (?q * ?q) (A' * B')))"
using pq.plus_Mp by metis
also have "pq.Mp (smult (?q * ?q) (A' * B')) = 0" unfolding qq
by (metis pq.Mp_smult_m_0 smult_smult)
finally have "pq.Mp (D * H + pq.Mp (smult ?q (A' * D + B' * H)))
= pq.Mp (D * H + pq.Mp (smult ?q (A * D + B * H)))" unfolding DH' by simp
hence "pq.Mp (smult ?q (A' * D + B' * H)) = pq.Mp (smult ?q (A * D + B * H))"
by (metis (no_types, lifting) add_diff_cancel_left' poly_mod.minus_Mp(1) poly_mod.plus_Mp(2))
hence "p.Mp (A' * D + B' * H) = p.Mp (A * D + B * H)" unfolding poly_eq_iff p.Mp_coeff pq.Mp_coeff coeff_smult
by (insert p, auto simp: p.M_def pq.M_def)
hence "p.Mp (A' * D1 + B' * H1) = p.Mp (A * D1 + B * H1)" using p_eq
by (metis p.mult_Mp(2) poly_mod.plus_Mp)
hence eq: "p.eq_m (A' * D1 + B' * H1) U" using dupe(1) by auto
have "degree D = degree D1" using monD monD1
arg_cong[OF p_eq(1), of degree]
p.degree_m_eq_monic[OF _ p.m1] by auto
hence "B' = 0 ∨ degree B' < degree D1" using degB' by simp
from dupe(5)[OF cop eq this normDH1(1) normA' normB' prime] have "A' = A" "B' = B" by auto
hence "D'' = D'" "H'' = H'" unfolding D'' H'' D' H' by auto
}
thus ?thesis using normD' normH' CDH mon eq by simp
qed
qed simp
end
end
definition linear_hensel_binary :: "int ⇒ nat ⇒ int poly ⇒ int poly ⇒ int poly ⇒ int poly × int poly" where
"linear_hensel_binary p n C D H = (let
(S,T) = euclid_ext_poly_dynamic p D H
in linear_hensel_main C p S T D H n)"
lemma (in poly_mod_prime) unique_hensel_binary:
assumes prime: "prime p"
and cop: "coprime_m D H" and eq: "eq_m (D * H) C"
and normalized_input: "Mp D = D" "Mp H = H"
and monic_input: "monic D"
and n: "n ≠ 0"
shows "∃! (D',H').
poly_mod.eq_m (p^n) (D' * H') C
∧ monic D'
∧ eq_m D D' ∧ eq_m H H'
∧ poly_mod.Mp (p^n) D' = D' ∧ poly_mod.Mp (p^n) H' = H' "
proof -
obtain D' H' where hensel_result: "linear_hensel_binary p n C D H = (D',H')" by force
from m1 have p: "p > 1" .
obtain S T where ext: "euclid_ext_poly_dynamic p D H = (S,T)" by force
obtain D1 H1 where main: "linear_hensel_main C p S T D H n = (D1,H1)" by force
from hensel_result[unfolded linear_hensel_binary_def ext split Let_def main]
have id: "D1 = D'" "H1 = H'" by auto
note eucl = euclid_ext_poly_dynamic [OF cop normalized_input ext]
from linear_hensel_main [OF eucl(1)
eq monic_input normalized_input main [unfolded id] n prime cop]
show ?thesis by (intro ex1I, auto)
qed
context
fixes C :: "int poly"
begin
lemma hensel_step_main: assumes
one_q: "poly_mod.eq_m q (D * S + H * T) 1"
and one_p: "poly_mod.eq_m p (D1 * S1 + H1 * T1) 1"
and CDHq: "poly_mod.eq_m q C (D * H)"
and D1D: "poly_mod.eq_m p D1 D"
and H1H: "poly_mod.eq_m p H1 H"
and S1S: "poly_mod.eq_m p S1 S"
and T1T: "poly_mod.eq_m p T1 T"
and mon: "monic D"
and mon1: "monic D1"
and q: "q > 1"
and p: "p > 1"
and D1: "poly_mod.Mp p D1 = D1"
and H1: "poly_mod.Mp p H1 = H1"
and S1: "poly_mod.Mp p S1 = S1"
and T1: "poly_mod.Mp p T1 = T1"
and D: "poly_mod.Mp q D = D"
and H: "poly_mod.Mp q H = H"
and S: "poly_mod.Mp q S = S"
and T: "poly_mod.Mp q T = T"
and U1: "U1 = poly_mod.Mp p (sdiv_poly (C - D * H) q)"
and dupe1: "dupe_monic_dynamic p D1 H1 S1 T1 U1 = (A,B)"
and D': "D' = D + smult q B"
and H': "H' = H + smult q A"
and U2: "U2 = poly_mod.Mp q (sdiv_poly (S*D' + T*H' - 1) p)"
and dupe2: "dupe_monic_dynamic q D H S T U2 = (A',B')"
and rq: "r = p * q"
and pq: "p dvd q"
and S': "S' = poly_mod.Mp r (S - smult p A')"
and T': "T' = poly_mod.Mp r (T - smult p B')"
shows "poly_mod.eq_m r C (D' * H')"
"poly_mod.Mp r D' = D'"
"poly_mod.Mp r H' = H'"
"poly_mod.Mp r S' = S'"
"poly_mod.Mp r T' = T'"
"poly_mod.eq_m r (D' * S' + H' * T') 1"
"monic D'"
unfolding rq
proof -
from pq obtain k where qp: "q = p * k" unfolding dvd_def by auto
from arg_cong[OF qp, of sgn] q p have k0: "k > 0" unfolding sgn_mult by (auto simp: sgn_1_pos)
from qp have qq: "q * q = p * q * k" by auto
let ?r = "p * q"
interpret poly_mod_2 p by (standard, insert p, auto)
interpret q: poly_mod_2 q by (standard, insert q, auto)
from p q have r: "?r > 1" by (simp add: less_1_mult)
interpret r: poly_mod_2 ?r using r unfolding poly_mod_2_def .
have Mp_conv: "Mp (q.Mp x) = Mp x" for x unfolding qp
by (rule Mp_product_modulus[OF refl k0])
from arg_cong[OF CDHq, of Mp, unfolded Mp_conv] have "Mp C = Mp (Mp D * Mp H)"
by simp
also have "Mp D = Mp D1" using D1D by simp
also have "Mp H = Mp H1" using H1H by simp
finally have CDHp: "eq_m C (D1 * H1)" by simp
have "Mp U1 = U1" unfolding U1 by simp
note dupe1 = dupe_monic_dynamic[OF dupe1 one_p mon1 D1 H1 S1 T1 this]
have "q.Mp U2 = U2" unfolding U2 by simp
note dupe2 = q.dupe_monic_dynamic[OF dupe2 one_q mon D H S T this]
from CDHq have "q.Mp C - q.Mp (D * H) = 0" by simp
hence "q.Mp (q.Mp C - q.Mp (D * H)) = 0" by simp
hence "q.Mp (C - D*H) = 0" by simp
from q.Mp_0_smult_sdiv_poly[OF this] have CDHq: "smult q (sdiv_poly (C - D * H) q) = C - D * H" .
{
fix A B
have "Mp (A * D1 + B * H1) = Mp (Mp (A * D1) + Mp (B * H1))" by simp
also have "Mp (A * D1) = Mp (A * Mp D1)" by simp
also have "… = Mp (A * D)" unfolding D1D by simp
also have "Mp (B * H1) = Mp (B * Mp H1)" by simp
also have "… = Mp (B * H)" unfolding H1H by simp
finally have "Mp (A * D1 + B * H1) = Mp (A * D + B * H)" by simp
} note D1H1 = this
have "r.Mp (D' * H') = r.Mp ((D + smult q B) * (H + smult q A))"
unfolding D' H' by simp
also have "(D + smult q B) * (H + smult q A) = (D * H + smult q (A * D + B * H)) + smult (q * q) (A * B)"
by (simp add: field_simps smult_distribs)
also have "r.Mp … = r.Mp (D * H + r.Mp (smult q (A * D + B * H)) + r.Mp (smult (q * q) (A * B)))"
using r.plus_Mp by metis
also have "r.Mp (smult (q * q) (A * B)) = 0" unfolding qq
by (metis r.Mp_smult_m_0 smult_smult)
also have "r.Mp (smult q (A * D + B * H)) = r.Mp (smult q U1)"
proof (rule Mp_lift_modulus[of _ _ q])
show "Mp (A * D + B * H) = Mp U1" using dupe1(1) unfolding D1H1 by simp
qed
also have "… = r.Mp (C - D * H)"
unfolding arg_cong[OF CDHq, of r.Mp, symmetric]
using Mp_lift_modulus[of U1 "sdiv_poly (C - D * H) q" q] unfolding U1
by simp
also have "r.Mp (D * H + r.Mp (C - D * H) + 0) = r.Mp C" by simp
finally show CDH: "r.eq_m C (D' * H')" by simp
have "degree D1 = degree (Mp D1)" using mon1 by simp
also have "… = degree D" unfolding D1D using mon by simp
finally have deg_eq: "degree D1 = degree D" by simp
show mon: "monic D'" unfolding D' using dupe1(2) mon unfolding deg_eq by (rule monic_smult_add_small)
have "Mp (S * D' + T * H' - 1) = Mp (Mp (D * S + H * T) + (smult q (S * B + T * A) - 1))"
unfolding D' H' plus_Mp by (simp add: field_simps smult_distribs)
also have "Mp (D * S + H * T) = Mp (Mp (D1 * Mp S) + Mp (H1 * Mp T))" using D1H1[of S T] by (simp add: ac_simps)
also have "… = 1" using one_p unfolding S1S[symmetric] T1T[symmetric] by simp
also have "Mp (1 + (smult q (S * B + T * A) - 1)) = Mp (smult q (S * B + T * A))" by simp
also have "… = 0" unfolding qp by (metis Mp_smult_m_0 smult_smult)
finally have "Mp (S * D' + T * H' - 1) = 0" .
from Mp_0_smult_sdiv_poly[OF this]
have SDTH: "smult p (sdiv_poly (S * D' + T * H' - 1) p) = S * D' + T * H' - 1" .
have swap: "q * p = p * q" by simp
have "r.Mp (D' * S' + H' * T') =
r.Mp ((D + smult q B) * (S - smult p A') + (H + smult q A) * (T - smult p B'))"
unfolding D' S' H' T' rq using r.plus_Mp r.mult_Mp by metis
also have "… = r.Mp ((D * S + H * T +
smult q (B * S + A * T)) - smult p (A' * D + B' * H) - smult ?r (A * B' + B * A'))"
by (simp add: field_simps smult_distribs)
also have "… = r.Mp ((D * S + H * T +
smult q (B * S + A * T)) - r.Mp (smult p (A' * D + B' * H)) - r.Mp (smult ?r (A * B' + B * A')))"
using r.plus_Mp r.minus_Mp by metis
also have "r.Mp (smult ?r (A * B' + B * A')) = 0" by simp
also have "r.Mp (smult p (A' * D + B' * H)) = r.Mp (smult p U2)"
using q.Mp_lift_modulus[OF dupe2(1), of p] unfolding swap .
also have "… = r.Mp (S * D' + T * H' - 1)"
unfolding arg_cong[OF SDTH, of r.Mp, symmetric]
using q.Mp_lift_modulus[of U2 "sdiv_poly (S * D' + T * H' - 1) p" p]
unfolding U2 swap by simp
also have "S * D' + T * H' - 1 = S * D + T * H + smult q (B * S + A * T) - 1"
unfolding D' H' by (simp add: field_simps smult_distribs)
also have "r.Mp (D * S + H * T + smult q (B * S + A * T) -
r.Mp (S * D + T * H + smult q (B * S + A * T) - 1) - 0)
= 1" by simp
finally show 1: "r.eq_m (D' * S' + H' * T') 1" by simp
show D': "r.Mp D' = D'" unfolding D' r.Mp_ident_iff poly_mod.Mp_coeff plus_poly.rep_eq
coeff_smult
proof
fix n
from D dupe1(4) have "coeff D n ∈ {0..<q}" "coeff B n ∈ {0..<p}"
unfolding q.Mp_ident_iff Mp_ident_iff by auto
thus "coeff D n + q * coeff B n ∈ {0..<?r}" by (metis range_sum_prod)
qed
show H': "r.Mp H' = H'" unfolding H' r.Mp_ident_iff poly_mod.Mp_coeff plus_poly.rep_eq
coeff_smult
proof
fix n
from H dupe1(3) have "coeff H n ∈ {0..<q}" "coeff A n ∈ {0..<p}"
unfolding q.Mp_ident_iff Mp_ident_iff by auto
thus "coeff H n + q * coeff A n ∈ {0..<?r}" by (metis range_sum_prod)
qed
show "poly_mod.Mp ?r S' = S'" "poly_mod.Mp ?r T' = T'"
unfolding S' T' rq by auto
qed
definition hensel_step where
"hensel_step p q S1 T1 D1 H1 S T D H = (
let U = poly_mod.Mp p (sdiv_poly (C - D * H) q);
(A,B) = dupe_monic_dynamic p D1 H1 S1 T1 U;
D' = D + smult q B;
H' = H + smult q A;
U' = poly_mod.Mp q (sdiv_poly (S*D' + T*H' - 1) p);
(A',B') = dupe_monic_dynamic q D H S T U';
q' = p * q;
S' = poly_mod.Mp q' (S - smult p A');
T' = poly_mod.Mp q' (T - smult p B')
in (S',T',D',H'))"
definition "quadratic_hensel_step q S T D H = hensel_step q q S T D H S T D H"
lemma quadratic_hensel_step_code[code]:
"quadratic_hensel_step q S T D H =
(let dupe = dupe_monic_dynamic q D H S T;
U = poly_mod.Mp q (sdiv_poly (C - D * H) q);
(A, B) = dupe U;
D' = D + Polynomial.smult q B;
H' = H + Polynomial.smult q A;
U' = poly_mod.Mp q (sdiv_poly (S * D' + T * H' - 1) q);
(A', B') = dupe U';
q' = q * q;
S' = poly_mod.Mp q' (S - Polynomial.smult q A');
T' = poly_mod.Mp q' (T - Polynomial.smult q B')
in (S', T', D', H'))"
unfolding quadratic_hensel_step_def[unfolded hensel_step_def] Let_def ..
definition simple_quadratic_hensel_step where
"simple_quadratic_hensel_step q S T D H = (
let U = poly_mod.Mp q (sdiv_poly (C - D * H) q);
(A,B) = dupe_monic_dynamic q D H S T U;
D' = D + smult q B;
H' = H + smult q A
in (D',H'))"
lemma hensel_step: assumes step: "hensel_step p q S1 T1 D1 H1 S T D H = (S', T', D', H')"
and one_p: "poly_mod.eq_m p (D1 * S1 + H1 * T1) 1"
and mon1: "monic D1"
and p: "p > 1"
and CDHq: "poly_mod.eq_m q C (D * H)"
and one_q: "poly_mod.eq_m q (D * S + H * T) 1"
and D1D: "poly_mod.eq_m p D1 D"
and H1H: "poly_mod.eq_m p H1 H"
and S1S: "poly_mod.eq_m p S1 S"
and T1T: "poly_mod.eq_m p T1 T"
and mon: "monic D"
and q: "q > 1"
and D1: "poly_mod.Mp p D1 = D1"
and H1: "poly_mod.Mp p H1 = H1"
and S1: "poly_mod.Mp p S1 = S1"
and T1: "poly_mod.Mp p T1 = T1"
and D: "poly_mod.Mp q D = D"
and H: "poly_mod.Mp q H = H"
and S: "poly_mod.Mp q S = S"
and T: "poly_mod.Mp q T = T"
and rq: "r = p * q"
and pq: "p dvd q"
shows
"poly_mod.eq_m r C (D' * H')"
"poly_mod.eq_m r (D' * S' + H' * T') 1"
"poly_mod.Mp r D' = D'"
"poly_mod.Mp r H' = H'"
"poly_mod.Mp r S' = S'"
"poly_mod.Mp r T' = T'"
"poly_mod.Mp p D1 = poly_mod.Mp p D'"
"poly_mod.Mp p H1 = poly_mod.Mp p H'"
"poly_mod.Mp p S1 = poly_mod.Mp p S'"
"poly_mod.Mp p T1 = poly_mod.Mp p T'"
"monic D'"
proof -
define U where U: "U = poly_mod.Mp p (sdiv_poly (C - D * H) q)"
note step = step[unfolded hensel_step_def Let_def, folded U]
obtain A B where dupe1: "dupe_monic_dynamic p D1 H1 S1 T1 U = (A,B)" by force
note step = step[unfolded dupe1 split]
from step have D': "D' = D + smult q B" and H': "H' = H + smult q A"
by (auto split: prod.splits)
define U' where U': "U' = poly_mod.Mp q (sdiv_poly (S * D' + T * H' - 1) p)"
obtain A' B' where dupe2: "dupe_monic_dynamic q D H S T U' = (A',B')" by force
from step[folded D' H', folded U', unfolded dupe2 split, folded rq]
have S': "S' = poly_mod.Mp r (S - Polynomial.smult p A')" and
T': "T' = poly_mod.Mp r (T - Polynomial.smult p B')" by auto
from hensel_step_main[OF one_q one_p CDHq D1D H1H S1S T1T mon mon1 q p D1 H1 S1 T1 D H S T U
dupe1 D' H' U' dupe2 rq pq S' T']
show "poly_mod.eq_m r (D' * S' + H' * T') 1"
"poly_mod.eq_m r C (D' * H')"
"poly_mod.Mp r D' = D'"
"poly_mod.Mp r H' = H'"
"poly_mod.Mp r S' = S'"
"poly_mod.Mp r T' = T'"
"monic D'" by auto
from pq obtain s where q: "q = p * s" by (metis dvdE)
show "poly_mod.Mp p D1 = poly_mod.Mp p D'"
"poly_mod.Mp p H1 = poly_mod.Mp p H'"
unfolding q D' D1D H' H1H
by (metis add.right_neutral poly_mod.Mp_smult_m_0 poly_mod.plus_Mp(2) smult_smult)+
from ‹q > 1› have q0: "q > 0" by auto
show "poly_mod.Mp p S1 = poly_mod.Mp p S'"
"poly_mod.Mp p T1 = poly_mod.Mp p T'"
unfolding S' S1S T' T1T poly_mod_2.Mp_product_modulus[OF poly_mod_2.intro[OF ‹p > 1›] rq q0]
by (metis group_add_class.diff_0_right poly_mod.Mp_smult_m_0 poly_mod.minus_Mp(2))+
qed
lemma quadratic_hensel_step: assumes step: "quadratic_hensel_step q S T D H = (S', T', D', H')"
and CDH: "poly_mod.eq_m q C (D * H)"
and one: "poly_mod.eq_m q (D * S + H * T) 1"
and D: "poly_mod.Mp q D = D"
and H: "poly_mod.Mp q H = H"
and S: "poly_mod.Mp q S = S"
and T: "poly_mod.Mp q T = T"
and mon: "monic D"
and q: "q > 1"
and rq: "r = q * q"
shows
"poly_mod.eq_m r C (D' * H')"
"poly_mod.eq_m r (D' * S' + H' * T') 1"
"poly_mod.Mp r D' = D'"
"poly_mod.Mp r H' = H'"
"poly_mod.Mp r S' = S'"
"poly_mod.Mp r T' = T'"
"poly_mod.Mp q D = poly_mod.Mp q D'"
"poly_mod.Mp q H = poly_mod.Mp q H'"
"poly_mod.Mp q S = poly_mod.Mp q S'"
"poly_mod.Mp q T = poly_mod.Mp q T'"
"monic D'"
proof (atomize(full), goal_cases)
case 1
from hensel_step[OF step[unfolded quadratic_hensel_step_def] one mon q CDH one refl refl refl refl mon q D H S T D H S T rq]
show ?case by auto
qed
context
fixes p :: int and S1 T1 D1 H1 :: "int poly"
begin
private lemma decrease[termination_simp]: "¬ j ≤ 1 ⟹ odd j ⟹ Suc (j div 2) < j" by presburger
fun quadratic_hensel_loop where
"quadratic_hensel_loop (j :: nat) = (
if j ≤ 1 then (p, S1, T1, D1, H1) else
if even j then
(case quadratic_hensel_loop (j div 2) of
(q, S, T, D, H) ⇒
let qq = q * q in
(case quadratic_hensel_step q S T D H of
(S', T', D', H') ⇒ (qq, S', T', D', H')))
else
(case quadratic_hensel_loop (j div 2 + 1) of
(q, S, T, D, H) ⇒
(case quadratic_hensel_step q S T D H of
(S', T', D', H') ⇒
let qq = q * q; pj = qq div p; down = poly_mod.Mp pj in
(pj, down S', down T', down D', down H'))))"
definition "quadratic_hensel_main j = (case quadratic_hensel_loop j of
(qq, S, T, D, H) ⇒ (D, H))"
declare quadratic_hensel_loop.simps[simp del]
lemma quadratic_hensel_main_code[code]: "quadratic_hensel_main j = (
if j ≤ 1 then (D1, H1)
else if even j
then (case quadratic_hensel_loop (j div 2) of
(q, S, T, D, H) ⇒
simple_quadratic_hensel_step q S T D H)
else (case quadratic_hensel_loop (j div 2 + 1) of
(q, S, T, D, H) ⇒
(case simple_quadratic_hensel_step q S T D H of
(D', H') ⇒ let down = poly_mod.Mp (q * q div p) in (down D', down H'))))"
unfolding quadratic_hensel_loop.simps[of j] quadratic_hensel_main_def Let_def
by (simp split: if_splits prod.splits option.splits sum.splits
add: quadratic_hensel_step_code simple_quadratic_hensel_step_def Let_def)
context
fixes j :: nat
assumes 1: "poly_mod.eq_m p (D1 * S1 + H1 * T1) 1"
and CDH1: "poly_mod.eq_m p C (D1 * H1)"
and mon1: "monic D1"
and p: "p > 1"
and D1: "poly_mod.Mp p D1 = D1"
and H1: "poly_mod.Mp p H1 = H1"
and S1: "poly_mod.Mp p S1 = S1"
and T1: "poly_mod.Mp p T1 = T1"
and j: "j ≥ 1"
begin
lemma quadratic_hensel_loop:
assumes "quadratic_hensel_loop j = (q, S, T, D, H)"
shows "(poly_mod.eq_m q C (D * H) ∧ monic D
∧ poly_mod.eq_m p D1 D ∧ poly_mod.eq_m p H1 H
∧ poly_mod.eq_m q (D * S + H * T) 1
∧ poly_mod.Mp q D = D ∧ poly_mod.Mp q H = H
∧ poly_mod.Mp q S = S ∧ poly_mod.Mp q T = T
∧ q = p^j)"
using j assms
proof (induct j arbitrary: q S T D H rule: less_induct)
case (less j q' S' T' D' H')
note res = less(3)
interpret poly_mod_2 p using p by (rule poly_mod_2.intro)
let ?hens = "quadratic_hensel_loop"
note simp[simp] = quadratic_hensel_loop.simps[of j]
show ?case
proof (cases "j = 1")
case True
show ?thesis using res simp unfolding True using CDH1 1 mon1 D1 H1 S1 T1 by auto
next
case False
with less(2) have False: "(j ≤ 1) = False" by auto
have mod_2: "k ≥ 1 ⟹ poly_mod_2 (p^k)" for k by (intro poly_mod_2.intro, insert p, auto)
{
fix k D
assume *: "k ≥ 1" "k ≤ j" "poly_mod.Mp (p ^ k) D = D"
from *(2) have "{0..<p ^ k} ⊆ {0..<p ^ j}" using p by auto
hence "poly_mod.Mp (p ^ j) D = D"
unfolding poly_mod_2.Mp_ident_iff[OF mod_2[OF less(2)]]
using *(3)[unfolded poly_mod_2.Mp_ident_iff[OF mod_2[OF *(1)]]] by blast
} note lift_norm = this
show ?thesis
proof (cases "even j")
case True
let ?j2 = "j div 2"
from False have lt: "?j2 < j" "1 ≤ ?j2" by auto
obtain q S T D H where rec: "?hens ?j2 = (q, S, T, D, H)" by (cases "?hens ?j2", auto)
note IH = less(1)[OF lt rec]
from IH
have *: "poly_mod.eq_m q C (D * H)"
"poly_mod.eq_m q (D * S + H * T) 1"
"monic D"
"eq_m D1 D"
"eq_m H1 H"
"poly_mod.Mp q D = D"
"poly_mod.Mp q H = H"
"poly_mod.Mp q S = S"
"poly_mod.Mp q T = T"
"q = p ^ ?j2"
by auto
hence norm: "poly_mod.Mp (p ^ j) D = D" "poly_mod.Mp (p ^ j) H = H"
"poly_mod.Mp (p ^ j) S = S" "poly_mod.Mp (p ^ j) T = T"
using lift_norm[OF lt(2)] by auto
from lt p have q: "q > 1" unfolding * by simp
let ?step = "quadratic_hensel_step q S T D H"
obtain S2 T2 D2 H2 where step_res: "?step = (S2, T2, D2, H2)" by (cases ?step, auto)
note step = quadratic_hensel_step[OF step_res *(1,2,6-9,3) q refl]
let ?qq = "q * q"
{
fix D D2
assume "poly_mod.Mp q D = poly_mod.Mp q D2"
from arg_cong[OF this, of Mp] Mp_Mp_pow_is_Mp[of ?j2, OF _ p, folded *(10)] lt
have "Mp D = Mp D2" by simp
} note shrink = this
have **: "poly_mod.eq_m ?qq C (D2 * H2)"
"poly_mod.eq_m ?qq (D2 * S2 + H2 * T2) 1"
"monic D2"
"eq_m D1 D2"
"eq_m H1 H2"
"poly_mod.Mp ?qq D2 = D2"
"poly_mod.Mp ?qq H2 = H2"
"poly_mod.Mp ?qq S2 = S2"
"poly_mod.Mp ?qq T2 = T2"
using step shrink[of H H2] shrink[of D D2] *(4-7) by auto
note simp = simp False if_False rec split Let_def step_res option.simps
from True have j: "p ^ j = p ^ (2 * ?j2)" by auto
with *(10) have qq: "q * q = p ^ j"
by (simp add: power_mult_distrib semiring_normalization_rules(30-))
from res[unfolded simp] True have id': "q' = ?qq" "S' = S2" "T' = T2" "D' = D2" "H' = H2" by auto
show ?thesis unfolding id' using ** by (auto simp: qq)
next
case odd: False
hence False': "(even j) = False" by auto
let ?j2 = "j div 2 + 1"
from False odd have lt: "?j2 < j" "1 ≤ ?j2" by presburger+
obtain q S T D H where rec: "?hens ?j2 = (q, S, T, D, H)" by (cases "?hens ?j2", auto)
note IH = less(1)[OF lt rec]
note simp = simp False if_False rec sum.simps split Let_def False' option.simps
from IH have *: "poly_mod.eq_m q C (D * H)"
"poly_mod.eq_m q (D * S + H * T) 1"
"monic D"
"eq_m D1 D"
"eq_m H1 H"
"poly_mod.Mp q D = D"
"poly_mod.Mp q H = H"
"poly_mod.Mp q S = S"
"poly_mod.Mp q T = T"
"q = p ^ ?j2"
by auto
hence norm: "poly_mod.Mp (p ^ j) D = D" "poly_mod.Mp (p ^ j) H = H"
using lift_norm[OF lt(2)] lt by auto
from lt p have q: "q > 1" unfolding *
using mod_2 poly_mod_2.m1 by blast
let ?step = "quadratic_hensel_step q S T D H"
obtain S2 T2 D2 H2 where step_res: "?step = (S2, T2, D2, H2)" by (cases ?step, auto)
have dvd: "q dvd q" by auto
note step = quadratic_hensel_step[OF step_res *(1,2,6-9,3) q refl]
let ?qq = "q * q"
{
fix D D2
assume "poly_mod.Mp q D = poly_mod.Mp q D2"
from arg_cong[OF this, of Mp] Mp_Mp_pow_is_Mp[of ?j2, OF _ p, folded *(10)] lt
have "Mp D = Mp D2" by simp
} note shrink = this
have **: "poly_mod.eq_m ?qq C (D2 * H2)"
"poly_mod.eq_m ?qq (D2 * S2 + H2 * T2) 1"
"monic D2"
"eq_m D1 D2"
"eq_m H1 H2"
"poly_mod.Mp ?qq D2 = D2"
"poly_mod.Mp ?qq H2 = H2"
"poly_mod.Mp ?qq S2 = S2"
"poly_mod.Mp ?qq T2 = T2"
using step shrink[of H H2] shrink[of D D2] *(4-7) by auto
note simp = simp False if_False rec split Let_def step_res option.simps
from odd have j: "Suc j = 2 * ?j2" by auto
from arg_cong[OF this, of "λ j. p ^ j div p"]
have pj: "p ^ j = q * q div p" and qq: "q * q = p ^ j * p" unfolding *(10) using p
by (simp add: power_mult_distrib semiring_normalization_rules(30-))+
let ?pj = "p ^ j"
from res[unfolded simp] pj
have id:
"q' = p^j"
"S' = poly_mod.Mp ?pj S2"
"T' = poly_mod.Mp ?pj T2"
"D' = poly_mod.Mp ?pj D2"
"H' = poly_mod.Mp ?pj H2"
by auto
interpret pj: poly_mod_2 ?pj by (rule mod_2[OF ‹1 ≤ j›])
have norm: "pj.Mp D' = D'" "pj.Mp H' = H'"
unfolding id by (auto simp: poly_mod.Mp_Mp)
have mon: "monic D'" using pj.monic_Mp[OF step(11)] unfolding id .
have id': "Mp (pj.Mp D) = Mp D" for D using ‹1 ≤ j›
by (simp add: Mp_Mp_pow_is_Mp p)
have eq: "eq_m D1 D2 ⟹ eq_m D1 (pj.Mp D2)" for D1 D2
unfolding id' by auto
have id'': "pj.Mp (poly_mod.Mp (q * q) D) = pj.Mp D" for D
unfolding qq by (rule pj.Mp_product_modulus[OF refl], insert p, auto)
{
fix D1 D2
assume "poly_mod.eq_m (q * q) D1 D2"
hence "poly_mod.Mp (q * q) D1 = poly_mod.Mp (q * q) D2" by simp
from arg_cong[OF this, of pj.Mp]
have "pj.Mp D1 = pj.Mp D2" unfolding id'' .
} note eq' = this
from eq'[OF step(1)] have eq1: "pj.eq_m C (D' * H')" unfolding id by simp
from eq'[OF step(2)] have eq2: "pj.eq_m (D' * S' + H' * T') 1"
unfolding id by (metis pj.mult_Mp pj.plus_Mp)
from **(4-5) have eq3: "eq_m D1 D'" "eq_m H1 H'"
unfolding id by (auto intro: eq)
from norm mon eq1 eq2 eq3
show ?thesis unfolding id by simp
qed
qed
qed
lemma quadratic_hensel_main: assumes res: "quadratic_hensel_main j = (D,H)"
shows "poly_mod.eq_m (p^j) C (D * H)"
"monic D"
"poly_mod.eq_m p D1 D"
"poly_mod.eq_m p H1 H"
"poly_mod.Mp (p^j) D = D"
"poly_mod.Mp (p^j) H = H"
proof (atomize(full), goal_cases)
case 1
let ?hen = "quadratic_hensel_loop j"
from res obtain q S T where hen: "?hen = (q, S, T, D, H)"
by (cases ?hen, auto simp: quadratic_hensel_main_def)
from quadratic_hensel_loop[OF hen] show ?case by auto
qed
end
end
end
datatype 'a factor_tree = Factor_Leaf 'a "int poly" | Factor_Node 'a "'a factor_tree" "'a factor_tree"
fun factor_node_info :: "'a factor_tree ⇒ 'a" where
"factor_node_info (Factor_Leaf i x) = i"
| "factor_node_info (Factor_Node i l r) = i"
fun factors_of_factor_tree :: "'a factor_tree ⇒ int poly multiset" where
"factors_of_factor_tree (Factor_Leaf i x) = {#x#}"
| "factors_of_factor_tree (Factor_Node i l r) = factors_of_factor_tree l + factors_of_factor_tree r"
fun product_factor_tree :: "int ⇒ 'a factor_tree ⇒ int poly factor_tree" where
"product_factor_tree p (Factor_Leaf i x) = (Factor_Leaf x x)"
| "product_factor_tree p (Factor_Node i l r) = (let
L = product_factor_tree p l;
R = product_factor_tree p r;
f = factor_node_info L;
g = factor_node_info R;
fg = poly_mod.Mp p (f * g)
in Factor_Node fg L R)"
fun sub_trees :: "'a factor_tree ⇒ 'a factor_tree set" where
"sub_trees (Factor_Leaf i x) = {Factor_Leaf i x}"
| "sub_trees (Factor_Node i l r) = insert (Factor_Node i l r) (sub_trees l ∪ sub_trees r)"
lemma sub_trees_refl[simp]: "t ∈ sub_trees t" by (cases t, auto)
lemma product_factor_tree: assumes "⋀ x. x ∈# factors_of_factor_tree t ⟹ poly_mod.Mp p x = x"
shows "u ∈ sub_trees (product_factor_tree p t) ⟹ factor_node_info u = f ⟹
poly_mod.Mp p f = f ∧ f = poly_mod.Mp p (prod_mset (factors_of_factor_tree u)) ∧
factors_of_factor_tree (product_factor_tree p t) = factors_of_factor_tree t"
using assms
proof (induct t arbitrary: u f)
case (Factor_Node i l r u f)
interpret poly_mod p .
let ?L = "product_factor_tree p l"
let ?R = "product_factor_tree p r"
let ?f = "factor_node_info ?L"
let ?g = "factor_node_info ?R"
let ?fg = "Mp (?f * ?g)"
have "Mp ?f = ?f ∧ ?f = Mp (prod_mset (factors_of_factor_tree ?L)) ∧
(factors_of_factor_tree ?L) = (factors_of_factor_tree l)"
by (rule Factor_Node(1)[OF sub_trees_refl refl], insert Factor_Node(5), auto)
hence IH1: "?f = Mp (prod_mset (factors_of_factor_tree ?L))"
"(factors_of_factor_tree ?L) = (factors_of_factor_tree l)" by blast+
have "Mp ?g = ?g ∧ ?g = Mp (prod_mset (factors_of_factor_tree ?R)) ∧
(factors_of_factor_tree ?R) = (factors_of_factor_tree r)"
by (rule Factor_Node(2)[OF sub_trees_refl refl], insert Factor_Node(5), auto)
hence IH2: "?g = Mp (prod_mset (factors_of_factor_tree ?R))"
"(factors_of_factor_tree ?R) = (factors_of_factor_tree r)" by blast+
have id: "(factors_of_factor_tree (product_factor_tree p (Factor_Node i l r))) =
(factors_of_factor_tree (Factor_Node i l r))" by (simp add: Let_def IH1 IH2)
from Factor_Node(3) consider (root) "u = Factor_Node ?fg ?L ?R"
| (l) "u ∈ sub_trees ?L" | (r) "u ∈ sub_trees ?R"
by (auto simp: Let_def)
thus ?case
proof cases
case root
with Factor_Node have f: "f = ?fg" by auto
show ?thesis unfolding f root id by (simp add: Let_def ac_simps IH1 IH2)
next
case l
have "Mp f = f ∧ f = Mp (prod_mset (factors_of_factor_tree u))"
using Factor_Node(1)[OF l Factor_Node(4)] Factor_Node(5) by auto
thus ?thesis unfolding id by blast
next
case r
have "Mp f = f ∧ f = Mp (prod_mset (factors_of_factor_tree u))"
using Factor_Node(2)[OF r Factor_Node(4)] Factor_Node(5) by auto
thus ?thesis unfolding id by blast
qed
qed auto
fun create_factor_tree_simple :: "int poly list ⇒ unit factor_tree" where
"create_factor_tree_simple xs = (let n = length xs in if n ≤ 1 then Factor_Leaf () (hd xs)
else let i = n div 2;
xs1 = take i xs;
xs2 = drop i xs
in Factor_Node () (create_factor_tree_simple xs1) (create_factor_tree_simple xs2)
)"
declare create_factor_tree_simple.simps[simp del]
lemma create_factor_tree_simple: "xs ≠ [] ⟹ factors_of_factor_tree (create_factor_tree_simple xs) = mset xs"
proof (induct xs rule: wf_induct[OF wf_measure[of length]])
case (1 xs)
from 1(2) have xs: "length xs ≠ 0" by auto
then consider (base) "length xs = 1" | (step) "length xs > 1" by linarith
thus ?case
proof cases
case base
then obtain x where xs: "xs = [x]" by (cases xs; cases "tl xs"; auto)
thus ?thesis by (auto simp: create_factor_tree_simple.simps)
next
case step
let ?i = "length xs div 2"
let ?xs1 = "take ?i xs"
let ?xs2 = "drop ?i xs"
from step have xs1: "(?xs1, xs) ∈ measure length" "?xs1 ≠ []" by auto
from step have xs2: "(?xs2, xs) ∈ measure length" "?xs2 ≠ []" by auto
from step have id: "create_factor_tree_simple xs = Factor_Node () (create_factor_tree_simple (take ?i xs))
(create_factor_tree_simple (drop ?i xs))" unfolding create_factor_tree_simple.simps[of xs] Let_def by auto
have xs: "xs = ?xs1 @ ?xs2" by auto
show ?thesis unfolding id arg_cong[OF xs, of mset] mset_append
using 1(1)[rule_format, OF xs1] 1(1)[rule_format, OF xs2]
by auto
qed
qed
text ‹We define a better factorization tree which balances the trees according to their degree.,
cf. Modern Computer Algebra, Chapter 15.5 on Multifactor Hensel lifting.›
fun partition_factors_main :: "nat ⇒ ('a × nat) list ⇒ ('a × nat) list × ('a × nat) list" where
"partition_factors_main s [] = ([], [])"
| "partition_factors_main s ((f,d) # xs) = (if d ≤ s then case partition_factors_main (s - d) xs of
(l,r) ⇒ ((f,d) # l, r) else case partition_factors_main d xs of
(l,r) ⇒ (l, (f,d) # r))"
lemma partition_factors_main: "partition_factors_main s xs = (a,b) ⟹ mset xs = mset a + mset b"
by (induct s xs arbitrary: a b rule: partition_factors_main.induct, auto split: if_splits prod.splits)
definition partition_factors :: "('a × nat) list ⇒ ('a × nat) list × ('a × nat) list" where
"partition_factors xs = (let n = sum_list (map snd xs) div 2 in
case partition_factors_main n xs of
([], x # y # ys) ⇒ ([x], y # ys)
| (x # y # ys, []) ⇒ ([x], y # ys)
| pair ⇒ pair)"
lemma partition_factors: "partition_factors xs = (a,b) ⟹ mset xs = mset a + mset b"
unfolding partition_factors_def Let_def
by (cases "partition_factors_main (sum_list (map snd xs) div 2) xs", auto split: list.splits
simp: partition_factors_main)
lemma partition_factors_length: assumes "¬ length xs ≤ 1" "(a,b) = partition_factors xs"
shows [termination_simp]: "length a < length xs" "length b < length xs" and "a ≠ []" "b ≠ []"
proof -
obtain ys zs where main: "partition_factors_main (sum_list (map snd xs) div 2) xs = (ys,zs)" by force
note res = assms(2)[unfolded partition_factors_def Let_def main split]
from arg_cong[OF partition_factors_main[OF main], of size] have len: "length xs = length ys + length zs" by auto
with assms(1) have len2: "length ys + length zs ≥ 2" by auto
from res len2 have "length a < length xs ∧ length b < length xs ∧ a ≠ [] ∧ b ≠ []" unfolding len
by (cases ys; cases zs; cases "tl ys"; cases "tl zs"; auto)
thus "length a < length xs" "length b < length xs" "a ≠ []" "b ≠ []" by blast+
qed
fun create_factor_tree_balanced :: "(int poly × nat)list ⇒ unit factor_tree" where
"create_factor_tree_balanced xs = (if length xs ≤ 1 then Factor_Leaf () (fst (hd xs)) else
case partition_factors xs of (l,r) ⇒ Factor_Node ()
(create_factor_tree_balanced l)
(create_factor_tree_balanced r))"
definition create_factor_tree :: "int poly list ⇒ unit factor_tree" where
"create_factor_tree xs = (let ys = map (λ f. (f, degree f)) xs;
zs = rev (sort_key snd ys)
in create_factor_tree_balanced zs)"
lemma create_factor_tree_balanced: "xs ≠ [] ⟹ factors_of_factor_tree (create_factor_tree_balanced xs) = mset (map fst xs)"
proof (induct xs rule: create_factor_tree_balanced.induct)
case (1 xs)
show ?case
proof (cases "length xs ≤ 1")
case True
with 1(3) obtain x where xs: "xs = [x]" by (cases xs; cases "tl xs", auto)
show ?thesis unfolding xs by auto
next
case False
obtain a b where part: "partition_factors xs = (a,b)" by force
note abp = this[symmetric]
note nonempty = partition_factors_length(3-4)[OF False abp]
note IH = 1(1)[OF False abp nonempty(1)] 1(2)[OF False abp nonempty(2)]
show ?thesis unfolding create_factor_tree_balanced.simps[of xs] part split using
False IH partition_factors[OF part] by auto
qed
qed
lemma create_factor_tree: assumes "xs ≠ []"
shows "factors_of_factor_tree (create_factor_tree xs) = mset xs"
proof -
let ?xs = "rev (sort_key snd (map (λf. (f, degree f)) xs))"
from assms have "set xs ≠ {}" by auto
hence "set ?xs ≠ {}" by auto
hence xs: "?xs ≠ []" by blast
show ?thesis unfolding create_factor_tree_def Let_def create_factor_tree_balanced[OF xs]
by (auto, induct xs, auto)
qed
context
fixes p :: int and n :: nat
begin
definition quadratic_hensel_binary :: "int poly ⇒ int poly ⇒ int poly ⇒ int poly × int poly" where
"quadratic_hensel_binary C D H = (
case euclid_ext_poly_dynamic p D H of
(S,T) ⇒ quadratic_hensel_main C p S T D H n)"
fun hensel_lifting_main :: "int poly ⇒ int poly factor_tree ⇒ int poly list" where
"hensel_lifting_main U (Factor_Leaf _ _) = [U]"
| "hensel_lifting_main U (Factor_Node _ l r) = (let
v = factor_node_info l;
w = factor_node_info r;
(V,W) = quadratic_hensel_binary U v w
in hensel_lifting_main V l @ hensel_lifting_main W r)"
definition hensel_lifting_monic :: "int poly ⇒ int poly list ⇒ int poly list" where
"hensel_lifting_monic u vs = (if vs = [] then [] else let
pn = p^n;
C = poly_mod.Mp pn u;
tree = product_factor_tree p (create_factor_tree vs)
in hensel_lifting_main C tree)"
definition hensel_lifting :: "int poly ⇒ int poly list ⇒ int poly list" where
"hensel_lifting f gs = (let lc = lead_coeff f;
ilc = inverse_mod lc (p^n);
g = smult ilc f
in hensel_lifting_monic g gs)"
end
context poly_mod_prime begin
context
fixes n :: nat
assumes n: "n ≠ 0"
begin
abbreviation "hensel_binary ≡ quadratic_hensel_binary p n"
abbreviation "hensel_main ≡ hensel_lifting_main p n"
lemma hensel_binary:
assumes cop: "coprime_m D H" and eq: "eq_m C (D * H)"
and normalized_input: "Mp D = D" "Mp H = H"
and monic_input: "monic D"
and hensel_result: "hensel_binary C D H = (D',H')"
shows "poly_mod.eq_m (p^n) C (D' * H')
∧ monic D'
∧ eq_m D D' ∧ eq_m H H'
∧ poly_mod.Mp (p^n) D' = D' ∧ poly_mod.Mp (p^n) H' = H' "
proof -
from m1 have p: "p > 1" .
obtain S T where ext: "euclid_ext_poly_dynamic p D H = (S,T)" by force
obtain D1 H1 where main: "quadratic_hensel_main C p S T D H n = (D1,H1)" by force
note hen = hensel_result[unfolded quadratic_hensel_binary_def ext split Let_def main]
from n have n: "n ≥ 1" by simp
note eucl = euclid_ext_poly_dynamic[OF cop normalized_input ext]
note main = quadratic_hensel_main[OF eucl(1) eq monic_input p normalized_input eucl(2-) n main]
show ?thesis using hen main by auto
qed
lemma hensel_main:
assumes eq: "eq_m C (prod_mset (factors_of_factor_tree Fs))"
and "⋀ F. F ∈# factors_of_factor_tree Fs ⟹ Mp F = F ∧ monic F"
and hensel_result: "hensel_main C Fs = Gs"
and C: "monic C" "poly_mod.Mp (p^n) C = C"
and sf: "square_free_m C"
and "⋀ f t. t ∈ sub_trees Fs ⟹ factor_node_info t = f ⟹ f = Mp (prod_mset (factors_of_factor_tree t))"
shows "poly_mod.eq_m (p^n) C (prod_list Gs)
∧ factors_of_factor_tree Fs = mset (map Mp Gs)
∧ (∀ G. G ∈ set Gs ⟶ monic G ∧ poly_mod.Mp (p^n) G = G)"
using assms
proof (induct Fs arbitrary: C Gs)
case (Factor_Leaf f fs C Gs)
thus ?case by auto
next
case (Factor_Node f l r C Gs) note * = this
note simps = hensel_lifting_main.simps
note IH1 = *(1)[rule_format]
note IH2 = *(2)[rule_format]
note res = *(5)[unfolded simps Let_def]
note eq = *(3)
note Fs = *(4)
note C = *(6,7)
note sf = *(8)
note inv = *(9)
interpret pn: poly_mod_2 "p^n" apply (unfold_locales) using m1 n by auto
let ?Mp = "pn.Mp"
define D where "D ≡ prod_mset (factors_of_factor_tree l)"
define H where "H ≡ prod_mset (factors_of_factor_tree r)"
let ?D = "Mp D"
let ?H = "Mp H"
let ?D' = "factor_node_info l"
let ?H' = "factor_node_info r"
obtain A B where hen: "hensel_binary C ?D' ?H' = (A,B)" by force
note res = res[unfolded hen split]
obtain AD where AD': "AD = hensel_main A l" by auto
obtain BH where BH': "BH = hensel_main B r" by auto
from inv[of l, OF _ refl] have D': "?D' = ?D" unfolding D_def by auto
from inv[of r, OF _ refl] have H': "?H' = ?H" unfolding H_def by auto
from eq[simplified]
have eq': "Mp C = Mp (?D * ?H)" unfolding D_def H_def by simp
from square_free_m_cong[OF sf, of "?D * ?H", OF eq']
have sf': "square_free_m (?D * ?H)" .
from poly_mod_prime.square_free_m_prod_imp_coprime_m[OF _ this]
have cop': "coprime_m ?D ?H" unfolding poly_mod_prime_def using prime .
from eq' have eq': "eq_m C (?D * ?H)" by simp
have monD: "monic D" unfolding D_def by (rule monic_prod_mset, insert Fs, auto)
from hensel_binary[OF _ _ _ _ _ hen, unfolded D' H', OF cop' eq' Mp_Mp Mp_Mp monic_Mp[OF monD]]
have step: "poly_mod.eq_m (p ^ n) C (A * B) ∧ monic A ∧ eq_m ?D A ∧
eq_m ?H B ∧ ?Mp A = A ∧ ?Mp B = B" .
from res have Gs: "Gs = AD @ BH" by (simp add: AD' BH')
have AD: "eq_m A ?D" "?Mp A = A" "eq_m A (prod_mset (factors_of_factor_tree l))"
and monA: "monic A"
using step by (auto simp: D_def)
note sf_fact = square_free_m_factor[OF sf']
from square_free_m_cong[OF sf_fact(1)] AD have sfA: "square_free_m A" by auto
have IH1: "poly_mod.eq_m (p ^ n) A (prod_list AD) ∧
factors_of_factor_tree l = mset (map Mp AD) ∧
(∀G. G ∈ set AD ⟶ monic G ∧ ?Mp G = G)"
by (rule IH1[OF AD(3) Fs AD'[symmetric] monA AD(2) sfA inv], auto)
have BH: "eq_m B ?H" "pn.Mp B = B" "eq_m B (prod_mset (factors_of_factor_tree r))"
using step by (auto simp: H_def)
from step have "pn.eq_m C (A * B)" by simp
hence "?Mp C = ?Mp (A * B)" by simp
with C AD(2) have "pn.Mp C = pn.Mp (A * pn.Mp B)" by simp
from arg_cong[OF this, of lead_coeff] C
have "monic (pn.Mp (A * B))" by simp
then have "lead_coeff (pn.Mp A) * lead_coeff (pn.Mp B) = 1"
by (metis lead_coeff_mult leading_coeff_neq_0 local.step mult_cancel_right2 pn.degree_m_eq pn.m1 poly_mod.M_def poly_mod.Mp_coeff)
with monA AD(2) BH(2) have monB: "monic B" by simp
from square_free_m_cong[OF sf_fact(2)] BH have sfB: "square_free_m B" by auto
have IH2: "poly_mod.eq_m (p ^ n) B (prod_list BH) ∧
factors_of_factor_tree r = mset (map Mp BH) ∧
(∀G. G ∈ set BH ⟶ monic G ∧ ?Mp G = G)"
by (rule IH2[OF BH(3) Fs BH'[symmetric] monB BH(2) sfB inv], auto)
from step have "?Mp C = ?Mp (?Mp A * ?Mp B)" by auto
also have "?Mp A = ?Mp (prod_list AD)" using IH1 by auto
also have "?Mp B = ?Mp (prod_list BH)" using IH2 by auto
finally have "poly_mod.eq_m (p ^ n) C (prod_list AD * prod_list BH)"
by (auto simp: poly_mod.mult_Mp)
thus ?case unfolding Gs using IH1 IH2 by auto
qed
lemma hensel_lifting_monic:
assumes eq: "poly_mod.eq_m p C (prod_list Fs)"
and Fs: "⋀ F. F ∈ set Fs ⟹ poly_mod.Mp p F = F ∧ monic F"
and res: "hensel_lifting_monic p n C Fs = Gs"
and mon: "monic (poly_mod.Mp (p^n) C)"
and sf: "poly_mod.square_free_m p C"
shows "poly_mod.eq_m (p^n) C (prod_list Gs)"
"mset (map (poly_mod.Mp p) Gs) = mset Fs"
"G ∈ set Gs ⟹ monic G ∧ poly_mod.Mp (p^n) G = G"
proof -
note res = res[unfolded hensel_lifting_monic_def Let_def]
let ?Mp = "poly_mod.Mp (p ^ n)"
let ?C = "?Mp C"
interpret poly_mod_prime p
by (unfold_locales, insert n prime, auto)
interpret pn: poly_mod_2 "p^n" using m1 n poly_mod_2.intro by auto
from eq n have eq: "eq_m (?Mp C) (prod_list Fs)"
using Mp_Mp_pow_is_Mp eq m1 n by force
have "poly_mod.eq_m (p^n) C (prod_list Gs) ∧ mset (map (poly_mod.Mp p) Gs) = mset Fs
∧ (G ∈ set Gs ⟶ monic G ∧ poly_mod.Mp (p^n) G = G)"
proof (cases "Fs = []")
case True
with res have Gs: "Gs = []" by auto
from eq have "Mp ?C = 1" unfolding True by simp
hence "degree (Mp ?C) = 0" by simp
with degree_m_eq_monic[OF mon m1] have "degree ?C = 0" by simp
with mon have "?C = 1" using monic_degree_0 by blast
thus ?thesis unfolding True Gs by auto
next
case False
let ?t = "create_factor_tree Fs"
note tree = create_factor_tree[OF False]
from False res have hen: "hensel_main ?C (product_factor_tree p ?t) = Gs" by auto
have tree1: "x ∈# factors_of_factor_tree ?t ⟹ Mp x = x" for x unfolding tree using Fs by auto
from product_factor_tree[OF tree1 sub_trees_refl refl, of ?t]
have id: "(factors_of_factor_tree (product_factor_tree p ?t)) =
(factors_of_factor_tree ?t)" by auto
have eq: "eq_m ?C (prod_mset (factors_of_factor_tree (product_factor_tree p ?t)))"
unfolding id tree using eq by auto
have id': "Mp C = Mp ?C" using n by (simp add: Mp_Mp_pow_is_Mp m1)
have "pn.eq_m ?C (prod_list Gs) ∧ mset Fs = mset (map Mp Gs) ∧ (∀G. G ∈ set Gs ⟶ monic G ∧ pn.Mp G = G)"
by (rule hensel_main[OF eq Fs hen mon pn.Mp_Mp square_free_m_cong[OF sf id'], unfolded id tree],
insert product_factor_tree[OF tree1], auto)
thus ?thesis by auto
qed
thus "poly_mod.eq_m (p^n) C (prod_list Gs)"
"mset (map (poly_mod.Mp p) Gs) = mset Fs"
"G ∈ set Gs ⟹ monic G ∧ poly_mod.Mp (p^n) G = G" by blast+
qed
lemma hensel_lifting:
assumes res: "hensel_lifting p n f fs = gs"
and cop: "coprime (lead_coeff f) p"
and sf: "poly_mod.square_free_m p f"
and fact: "poly_mod.factorization_m p f (c, mset fs)"
and c: "c ∈ {0..<p}"
and norm: "(∀fi∈set fs. set (coeffs fi) ⊆ {0..<p})"
shows "poly_mod.factorization_m (p^n) f (lead_coeff f, mset gs) "
"sort (map degree fs) = sort (map degree gs) "
"⋀ g. g ∈ set gs ⟹ monic g ∧ poly_mod.Mp (p^n) g = g ∧
irreducible_m g ∧
degree_m g = degree g "
proof -
interpret poly_mod_prime p using prime by unfold_locales
interpret q: poly_mod_2 "p^n" using m1 n unfolding poly_mod_2_def by auto
from fact have eq: "eq_m f (smult c (prod_list fs))"
and mon_fs: "(∀fi∈set fs. monic (Mp fi) ∧ irreducible⇩d_m fi)"
unfolding factorization_m_def by auto
{
fix f
assume "f ∈ set fs"
with mon_fs norm have "set (coeffs f) ⊆ {0..<p}" and "monic (Mp f)" by auto
hence "monic f" using Mp_ident_iff' by force
} note mon_fs' = this
have Mp_id: "⋀ f. Mp (q.Mp f) = Mp f" by (simp add: Mp_Mp_pow_is_Mp m1 n)
let ?lc = "lead_coeff f"
let ?q = "p ^ n"
define ilc where "ilc ≡ inverse_mod ?lc ?q"
define F where "F ≡ smult ilc f"
from res[unfolded hensel_lifting_def Let_def]
have hen: "hensel_lifting_monic p n F fs = gs"
unfolding ilc_def F_def .
from m1 n cop have inv: "q.M (ilc * ?lc) = 1"
by (auto simp add: q.M_def inverse_mod_pow ilc_def)
hence ilc0: "ilc ≠ 0" by (cases "ilc = 0", auto)
{
fix q
assume "ilc * ?lc = ?q * q"
from arg_cong[OF this, of q.M] have "q.M (ilc * ?lc) = 0"
unfolding q.M_def by auto
with inv have False by auto
} note not_dvd = this
have mon: "monic (q.Mp F)" unfolding F_def q.Mp_coeff coeff_smult
by (subst q.degree_m_eq [OF _ q.m1]) (auto simp: inv ilc0 [symmetric] intro: not_dvd)
have "q.Mp f = q.Mp (smult (q.M (?lc * ilc)) f)" using inv by (simp add: ac_simps)
also have "… = q.Mp (smult ?lc F)" by (simp add: F_def)
finally have f: "q.Mp f = q.Mp (smult ?lc F)" .
from arg_cong[OF f, of Mp]
have f_p: "Mp f = Mp (smult ?lc F)"
by (simp add: Mp_Mp_pow_is_Mp n m1)
from arg_cong[OF this, of square_free_m, unfolded Mp_square_free_m] sf
have "square_free_m (smult ?lc F)" by simp
from square_free_m_smultD[OF this] have sf: "square_free_m F" .
define c' where "c' ≡ M (c * ilc)"
from factorization_m_smult[OF fact, of ilc, folded F_def]
have fact: "factorization_m F (c', mset fs)" unfolding c'_def factorization_m_def by auto
hence eq: "eq_m F (smult c' (prod_list fs))" unfolding factorization_m_def by auto
from factorization_m_lead_coeff[OF fact] monic_Mp[OF mon, unfolded Mp_id] have "M c' = 1"
by auto
hence c': "c' = 1" unfolding c'_def by auto
with eq have eq: "eq_m F (prod_list fs)" by auto
{
fix f
assume "f ∈ set fs"
with mon_fs' norm have "Mp f = f ∧ monic f" unfolding Mp_ident_iff'
by auto
} note fs = this
note hen = hensel_lifting_monic[OF eq fs hen mon sf]
from hen(2) have gs_fs: "mset (map Mp gs) = mset fs" by auto
have eq: "q.eq_m f (smult ?lc (prod_list gs))"
unfolding f using arg_cong[OF hen(1), of "λ f. q.Mp (smult ?lc f)"] by simp
{
fix g
assume g: "g ∈ set gs"
from hen(3)[OF _ g] have mon_g: "monic g" and Mp_g: "q.Mp g = g" by auto
from g have "Mp g ∈# mset (map Mp gs)" by auto
from this[unfolded gs_fs] obtain f where f: "f ∈ set fs" and fg: "eq_m f g" by auto
from mon_fs f fs have irr_f: "irreducible⇩d_m f" and mon_f: "monic f" and Mp_f: "Mp f = f" by auto
have deg: "degree_m g = degree g"
by (rule degree_m_eq_monic[OF mon_g m1])
from irr_f fg have irr_g: "irreducible⇩d_m g"
unfolding irreducible⇩d_m_def dvdm_def by simp
have "q.irreducible⇩d_m g"
by (rule irreducible⇩d_lifting[OF n _ irr_g], unfold deg, rule q.degree_m_eq_monic[OF mon_g q.m1])
note mon_g Mp_g deg irr_g this
} note g = this
{
fix g
assume "g ∈ set gs"
from g[OF this]
show "monic g ∧ q.Mp g = g ∧ irreducible_m g ∧ degree_m g = degree g" by auto
}
show "sort (map degree fs) = sort (map degree gs)"
proof (rule sort_key_eq_sort_key)
have "mset (map degree fs) = image_mset degree (mset fs)" by auto
also have "… = image_mset degree (mset (map Mp gs))" unfolding gs_fs ..
also have "… = mset (map degree (map Mp gs))" unfolding mset_map ..
also have "map degree (map Mp gs) = map degree_m gs" by auto
also have "… = map degree gs" using g(3) by auto
finally show "mset (map degree fs) = mset (map degree gs)" .
qed auto
show "q.factorization_m f (lead_coeff f, mset gs)"
using eq g unfolding q.factorization_m_def by auto
qed
end
end
end
Theory Hensel_Lifting_Type_Based
theory Hensel_Lifting_Type_Based
imports Hensel_Lifting
begin
subsection‹Hensel Lifting in a Type-Based Setting›
lemma degree_smult_eq_iff:
"degree (smult a p) = degree p ⟷ degree p = 0 ∨ a * lead_coeff p ≠ 0"
by (metis (no_types, lifting) coeff_smult degree_0 degree_smult_le le_antisym
le_degree le_zero_eq leading_coeff_0_iff)
lemma degree_smult_eqI[intro!]:
assumes "degree p ≠ 0 ⟹ a * lead_coeff p ≠ 0"
shows "degree (smult a p) = degree p"
using assms degree_smult_eq_iff by auto
lemma degree_mult_eq2:
assumes lc: "lead_coeff p * lead_coeff q ≠ 0"
shows "degree (p * q) = degree p + degree q" (is "_ = ?r")
proof(intro antisym[OF degree_mult_le] le_degree, unfold coeff_mult)
let ?f = "λi. coeff p i * coeff q (?r - i)"
have "(∑i≤?r. ?f i) = sum ?f {..degree p} + sum ?f {Suc (degree p)..?r}"
by (rule sum_up_index_split)
also have "sum ?f {Suc (degree p)..?r} = 0"
proof-
{ fix x assume "x > degree p"
then have "coeff p x = 0" by (rule coeff_eq_0)
then have "?f x = 0" by auto
}
then show ?thesis by (intro sum.neutral, auto)
qed
also have "sum ?f {..degree p} = sum ?f {..<degree p} + ?f (degree p)"
by(fold lessThan_Suc_atMost, unfold sum.lessThan_Suc, auto)
also have "sum ?f {..<degree p} = 0"
proof-
{fix x assume "x < degree p"
then have "coeff q (?r - x) = 0" by (intro coeff_eq_0, auto)
then have "?f x = 0" by auto
}
then show ?thesis by (intro sum.neutral, auto)
qed
finally show "(∑i≤?r. ?f i) ≠ 0" using assms by (auto simp:)
qed
lemma degree_mult_eq_left_unit:
fixes p q :: "'a :: comm_semiring_1 poly"
assumes unit: "lead_coeff p dvd 1" and q0: "q ≠ 0"
shows "degree (p * q) = degree p + degree q"
proof(intro degree_mult_eq2 notI)
from unit obtain c where "lead_coeff p * c = 1" by (elim dvdE,auto)
then have "c * lead_coeff p = 1" by (auto simp: ac_simps)
moreover assume "lead_coeff p * lead_coeff q = 0"
then have "c * lead_coeff p * lead_coeff q = 0" by (auto simp: ac_simps)
ultimately have "lead_coeff q = 0" by auto
with q0 show False by auto
qed
context ring_hom begin
lemma monic_degree_map_poly_hom: "monic p ⟹ degree (map_poly hom p) = degree p"
by (auto intro: degree_map_poly)
lemma monic_map_poly_hom: "monic p ⟹ monic (map_poly hom p)"
by (simp add: monic_degree_map_poly_hom)
end
lemma of_nat_zero:
assumes "CARD('a::nontriv) dvd n"
shows "(of_nat n :: 'a mod_ring) = 0"
apply (transfer fixing: n) using assms by (presburger)
abbreviation rebase :: "'a :: nontriv mod_ring ⇒ 'b :: nontriv mod_ring "("@_" [100]100)
where "@x ≡ of_int (to_int_mod_ring x)"
abbreviation rebase_poly :: "'a :: nontriv mod_ring poly ⇒ 'b :: nontriv mod_ring poly" ("#_" [100]100)
where "#x ≡ of_int_poly (to_int_poly x)"
lemma rebase_self [simp]:
"@x = x"
by (simp add: of_int_of_int_mod_ring)
lemma map_poly_rebase [simp]:
"map_poly rebase p = #p"
by (induct p) simp_all
lemma rebase_poly_0: "#0 = 0"
by simp
lemma rebase_poly_1: "#1 = 1"
by simp
lemma rebase_poly_pCons[simp]: "#pCons a p = pCons (@a) (#p)"
by(cases "a = 0 ∧ p = 0", simp, fold map_poly_rebase, subst map_poly_pCons, auto)
lemma rebase_poly_self[simp]: "#p = p" by (induct p, auto)
lemma degree_rebase_poly_le: "degree (#p) ≤ degree p"
by (fold map_poly_rebase, subst degree_map_poly_le, auto)
lemma(in comm_ring_hom) degree_map_poly_unit: assumes "lead_coeff p dvd 1"
shows "degree (map_poly hom p) = degree p"
using hom_dvd_1[OF assms] by (auto intro: degree_map_poly)
lemma rebase_poly_eq_0_iff:
"(#p :: 'a :: nontriv mod_ring poly) = 0 ⟷ (∀i. (@coeff p i :: 'a mod_ring) = 0)" (is "?l ⟷ ?r")
proof(intro iffI)
assume ?l
then have "coeff (#p :: 'a mod_ring poly) i = 0" for i by auto
then show ?r by auto
next
assume ?r
then have "coeff (#p :: 'a mod_ring poly) i = 0" for i by auto
then show ?l by (intro poly_eqI, auto)
qed
lemma mod_mod_le:
assumes ab: "(a::int) ≤ b" and a0: "0 < a" and c0: "c ≥ 0" shows "(c mod a) mod b = c mod a"
by (meson Divides.pos_mod_bound Divides.pos_mod_sign a0 ab less_le_trans mod_pos_pos_trivial)
locale rebase_ge =
fixes ty1 :: "'a :: nontriv itself" and ty2 :: "'b :: nontriv itself"
assumes card: "CARD('a) ≤ CARD('b)"
begin
lemma ab: "int CARD('a) ≤ CARD('b)" using card by auto
lemma rebase_eq_0[simp]:
shows "(@(x :: 'a mod_ring) :: 'b mod_ring) = 0 ⟷ x = 0"
using card by (transfer, auto)
lemma degree_rebase_poly_eq[simp]:
shows "degree (#(p :: 'a mod_ring poly) :: 'b mod_ring poly) = degree p"
by (subst degree_map_poly; simp)
lemma lead_coeff_rebase_poly[simp]:
"lead_coeff (#(p::'a mod_ring poly) :: 'b mod_ring poly) = @lead_coeff p"
by simp
lemma to_int_mod_ring_rebase: "to_int_mod_ring(@(x :: 'a mod_ring)::'b mod_ring) = to_int_mod_ring x"
using card by (transfer, auto)
lemma rebase_id[simp]: "@(@(x::'a mod_ring) :: 'b mod_ring) = @x"
using card by (transfer, auto)
lemma rebase_poly_id[simp]: "#(#(p::'a mod_ring poly) :: 'b mod_ring poly) = #p" by (induct p, auto)
end
locale rebase_dvd =
fixes ty1 :: "'a :: nontriv itself" and ty2 :: "'b :: nontriv itself"
assumes dvd: "CARD('b) dvd CARD('a)"
begin
lemma ab: "CARD('a) ≥ CARD('b)" by (rule dvd_imp_le[OF dvd], auto)
lemma rebase_id[simp]: "@(@(x::'b mod_ring) :: 'a mod_ring) = x" using ab by (transfer, auto)
lemma rebase_poly_id[simp]: "#(#(p::'b mod_ring poly) :: 'a mod_ring poly) = p" by (induct p, auto)
lemma rebase_of_nat[simp]: "(@(of_nat n :: 'a mod_ring) :: 'b mod_ring) = of_nat n"
apply transfer apply (rule mod_mod_cancel) using dvd by presburger
lemma mod_1_lift_nat:
assumes "(of_int (int x) :: 'a mod_ring) = 1"
shows "(of_int (int x) :: 'b mod_ring) = 1"
proof -
from assms have "int x mod CARD('a) = 1"
by transfer
then have "x mod CARD('a) = 1"
by (simp add: of_nat_mod [symmetric])
then have "x mod CARD('b) = 1"
by (metis dvd mod_mod_cancel one_mod_card)
then have "int x mod CARD('b) = 1"
by (simp add: of_nat_mod [symmetric])
then show ?thesis
by transfer
qed
sublocale comm_ring_hom "rebase :: 'a mod_ring ⇒ 'b mod_ring"
proof
fix x y :: "'a mod_ring"
show hom_add: "(@(x+y) :: 'b mod_ring) = @x + @y"
by transfer (simp add: mod_simps dvd mod_mod_cancel)
show "(@(x*y) :: 'b mod_ring) = @x * @y"
by transfer (simp add: mod_simps dvd mod_mod_cancel)
qed auto
lemma of_nat_CARD_eq_0[simp]: "(of_nat CARD('a) :: 'b mod_ring) = 0"
using dvd by (transfer, presburger)
interpretation map_poly_hom: map_poly_comm_ring_hom "rebase :: 'a mod_ring ⇒ 'b mod_ring"..
sublocale poly: comm_ring_hom "rebase_poly :: 'a mod_ring poly ⇒ 'b mod_ring poly"
by (fold map_poly_rebase, unfold_locales)
lemma poly_rebase[simp]: "@poly p x = poly (#(p :: 'a mod_ring poly) :: 'b mod_ring poly) (@(x::'a mod_ring) :: 'b mod_ring)"
by (fold map_poly_rebase poly_map_poly, rule)
lemma rebase_poly_smult[simp]: "(#(smult a p :: 'a mod_ring poly) :: 'b mod_ring poly) = smult (@a) (#p)"
by(induct p, auto simp: hom_distribs)
end
locale rebase_mult =
fixes ty1 :: "'a :: nontriv itself"
and ty2 :: "'b :: nontriv itself"
and ty3 :: "'d :: nontriv itself"
assumes d: "CARD('a) = CARD('b) * CARD('d)"
begin
sublocale rebase_dvd ty1 ty2 using d by (unfold_locales, auto)
lemma rebase_mult_eq[simp]: "(of_nat CARD('d) * a :: 'a mod_ring) = of_nat CARD('d) * a' ⟷ (@a :: 'b mod_ring) = @a'"
proof-
from dvd obtain d' where "CARD('a) = d' * CARD('b)" by (elim dvdE, auto)
then show ?thesis by (transfer, auto simp:d)
qed
lemma rebase_poly_smult_eq[simp]:
fixes a a' :: "'a mod_ring poly"
defines "d ≡ of_nat CARD('d) :: 'a mod_ring"
shows "smult d a = smult d a' ⟷ (#a :: 'b mod_ring poly) = #a'" (is "?l ⟷ ?r")
proof (intro iffI)
assume l: ?l show "?r"
proof (intro poly_eqI)
fix n
from l have "coeff (smult d a) n = coeff (smult d a') n" by auto
then have "d * coeff a n = d * coeff a' n" by auto
from this[unfolded d_def rebase_mult_eq]
show "coeff (#a :: 'b mod_ring poly) n = coeff (#a') n" by auto
qed
next
assume r: ?r show ?l
proof(intro poly_eqI)
fix n
from r have "coeff (#a :: 'b mod_ring poly) n = coeff (#a') n" by auto
then have "(@coeff a n :: 'b mod_ring) = @coeff a' n" by auto
from this[folded d_def rebase_mult_eq]
show "coeff (smult d a) n = coeff (smult d a') n" by auto
qed
qed
lemma rebase_eq_0_imp_ex_mult:
"(@(a :: 'a mod_ring) :: 'b mod_ring) = 0 ⟹ (∃c :: 'd mod_ring. a = of_nat CARD('b) * @c)" (is "?l ⟹ ?r")
proof(cases "CARD('a) = CARD('b)")
case True then show "?l ⟹ ?r"
by (transfer, auto)
next
case False
have [simp]: "int CARD('b) mod int CARD('a) = int CARD('b)"
by(rule mod_pos_pos_trivial, insert ab False, auto)
{
fix a
assume a: "0 ≤ a" "a < int CARD('a)" and mod: "a mod int CARD('b) = 0"
from mod have "int CARD('b) dvd a" by auto
then obtain i where *: "a = int CARD('b) * i" by (elim dvdE, auto)
from * a have "i < int CARD('d)" by (simp add:d)
moreover
hence "(i mod int CARD('a)) = i"
by (metis dual_order.order_iff_strict less_le_trans not_le of_nat_less_iff "*" a(1) a(2)
mod_pos_pos_trivial mult_less_cancel_right1 nat_neq_iff nontriv of_nat_1)
with * a have "a = int CARD('b) * (i mod int CARD('a)) mod int CARD('a)"
by (auto simp:d)
moreover from * a have "0 ≤ i"
using linordered_semiring_strict_class.mult_pos_neg of_nat_0_less_iff zero_less_card_finite
by (simp add: zero_le_mult_iff)
ultimately have "∃i≥0. i < int CARD('d) ∧ a = int CARD('b) * (i mod int CARD('a)) mod int CARD('a)"
by (auto intro: exI[of _ i])
}
then show "?l ⟹ ?r" by (transfer, auto simp:d)
qed
lemma rebase_poly_eq_0_imp_ex_smult:
"(#(p :: 'a mod_ring poly) :: 'b mod_ring poly) = 0 ⟹
(∃p' :: 'd mod_ring poly. (p = 0 ⟷ p' = 0) ∧ degree p' ≤ degree p ∧ p = smult (of_nat CARD('b)) (#p'))"
(is "?l ⟹ ?r")
proof(induct p)
case 0
then show ?case by (intro exI[of _ 0],auto)
next
case IH: (pCons a p)
from IH(3) have "(#p :: 'b mod_ring poly) = 0" by auto
from IH(2)[OF this] obtain p' :: "'d mod_ring poly"
where *: "p = 0 ⟷ p' = 0" "degree p' ≤ degree p" "p = smult (of_nat CARD('b)) (#p')" by (elim exE conjE)
from IH have "(@a :: 'b mod_ring) = 0" by auto
from rebase_eq_0_imp_ex_mult[OF this]
obtain a' :: "'d mod_ring" where a': "of_nat CARD('b) * (@a') = a" by auto
from IH(1) have "pCons a p ≠ 0" by auto
moreover from *(1,2) have "degree (pCons a' p') ≤ degree (pCons a p)" by auto
moreover from a' *(3)
have "pCons a p = smult (of_nat CARD('b)) (#pCons a' p')" by auto
ultimately show ?case by (intro exI[of _ "pCons a' p'"], auto)
qed
end
lemma mod_mod_nat[simp]: "a mod b mod (b * c :: nat) = a mod b" by (simp add: Divides.mod_mult2_eq)
locale Knuth_ex_4_6_2_22_base =
fixes ty_p :: "'p :: nontriv itself"
and ty_q :: "'q :: nontriv itself"
and ty_pq :: "'pq :: nontriv itself"
assumes pq: "CARD('pq) = CARD('p) * CARD('q)"
and p_dvd_q: "CARD('p) dvd CARD('q)"
begin
sublocale rebase_q_to_p: rebase_dvd "TYPE('q)" "TYPE('p)" using p_dvd_q by (unfold_locales, auto)
sublocale rebase_pq_to_p: rebase_mult "TYPE('pq)" "TYPE('p)" "TYPE('q)" using pq by (unfold_locales, auto)
sublocale rebase_pq_to_q: rebase_mult "TYPE('pq)" "TYPE('q)" "TYPE('p)" using pq by (unfold_locales, auto)
sublocale rebase_p_to_q: rebase_ge "TYPE('p)" "TYPE ('q)" by (unfold_locales, insert p_dvd_q, simp add: dvd_imp_le)
sublocale rebase_p_to_pq: rebase_ge "TYPE('p)" "TYPE ('pq)" by (unfold_locales, simp add: pq)
sublocale rebase_q_to_pq: rebase_ge "TYPE('q)" "TYPE ('pq)" by (unfold_locales, simp add: pq)
definition "p ≡ if (ty_p :: 'p itself) = ty_p then CARD('p) else undefined"
lemma p[simp]: "p ≡ CARD('p)" unfolding p_def by auto
definition "q ≡ if (ty_q :: 'q itself) = ty_q then CARD('q) else undefined"
lemma q[simp]: "q = CARD('q)" unfolding q_def by auto
lemma p1: "int p > 1"
using nontriv [where ?'a = 'p] p by simp
lemma q1: "int q > 1"
using nontriv [where ?'a = 'q] q by simp
lemma q0: "int q > 0"
using q1 by auto
lemma pq2[simp]: "CARD('pq) = p * q" using pq by simp
lemma qq_eq_0[simp]: "(of_nat CARD('q) * of_nat CARD('q) :: 'pq mod_ring) = 0"
proof-
have "(of_nat (q * q) :: 'pq mod_ring) = 0" by (rule of_nat_zero, auto simp: p_dvd_q)
then show ?thesis by auto
qed
lemma of_nat_q[simp]: "of_nat q :: 'q mod_ring ≡ 0" by (fold of_nat_card_eq_0, auto)
lemma rebase_rebase[simp]: "(@(@(x::'pq mod_ring) :: 'q mod_ring) :: 'p mod_ring) = @x"
using p_dvd_q by (transfer) (simp add: mod_mod_cancel)
lemma rebase_rebase_poly[simp]: "(#(#(f::'pq mod_ring poly) :: 'q mod_ring poly) :: 'p mod_ring poly) = #f"
by (induct f, auto)
end
definition dupe_monic where
"dupe_monic D H S T U = (case pdivmod_monic (T * U) D of (q,r) ⇒ (S * U + H * q, r))"
lemma dupe_monic:
fixes D :: "'a :: prime_card mod_ring poly"
assumes 1: "D*S + H*T = 1"
and mon: "monic D"
and dupe: "dupe_monic D H S T U = (A,B)"
shows "A * D + B * H = U" "B = 0 ∨ degree B < degree D"
"coprime D H ⟹ A' * D + B' * H = U ⟹ B' = 0 ∨ degree B' < degree D ⟹ A' = A ∧ B' = B"
proof -
obtain q r where div: "pdivmod_monic (T * U) D = (q,r)" by force
from dupe[unfolded dupe_monic_def div split]
have A: "A = (S * U + H * q)" and B: "B = r" by auto
from pdivmod_monic[OF mon div] have TU: "T * U = D * q + r" and
deg: "r = 0 ∨ degree r < degree D" by auto
hence r: "r = T * U - D * q" by simp
have "A * D + B * H = (S * U + H * q) * D + (T * U - D * q) * H" unfolding A B r by simp
also have "... = (D * S + H * T) * U" by (simp add: field_simps)
also have "D * S + H * T = 1" using 1 by simp
finally show eq: "A * D + B * H = U" by simp
show degB: "B = 0 ∨ degree B < degree D" using deg unfolding B by (cases "r = 0", auto)
assume another: "A' * D + B' * H = U" and degB': "B' = 0 ∨ degree B' < degree D"
and cop: "coprime D H"
from degB have degB: "B = 0 ∨ degree B < degree D" by auto
from degB' have degB': "B' = 0 ∨ degree B' < degree D" by auto
from mon have D0: "D ≠ 0" by auto
from another eq have "A' * D + B' * H = A * D + B * H" by simp
from uniqueness_poly_equality[OF cop degB' degB D0 this]
show "A' = A ∧ B' = B" by auto
qed
locale Knuth_ex_4_6_2_22_main = Knuth_ex_4_6_2_22_base p_ty q_ty pq_ty
for p_ty :: "'p::nontriv itself"
and q_ty :: "'q::nontriv itself"
and pq_ty :: "'pq::nontriv itself" +
fixes a b :: "'p mod_ring poly" and u :: "'pq mod_ring poly" and v w :: "'q mod_ring poly"
assumes uvw: "(#u :: 'q mod_ring poly) = v * w"
and degu: "degree u = degree v + degree w"
and avbw: "(a * #v + b * #w :: 'p mod_ring poly) = 1"
and monic_v: "monic v"
and bv: "degree b < degree v"
begin
lemma deg_v: "degree (#v :: 'p mod_ring poly) = degree v"
using monic_v by (simp add: of_int_hom.monic_degree_map_poly_hom)
lemma u0: "u ≠ 0" using degu bv by auto
lemma ex_f: "∃f :: 'p mod_ring poly. u = #v * #w + smult (of_nat q) (#f)"
proof-
from uvw have "(#(u - #v * #w) :: 'q mod_ring poly) = 0" by (auto simp:hom_distribs)
from rebase_pq_to_q.rebase_poly_eq_0_imp_ex_smult[OF this]
obtain f :: "'p mod_ring poly" where "u - #v * #w = smult (of_nat q) (#f)" by force
then have "u = #v * #w + smult (of_nat q) (#f)" by (metis add_diff_cancel_left' add_diff_eq)
then show ?thesis by (intro exI[of _ f], auto)
qed
definition "f :: 'p mod_ring poly ≡ SOME f. u = #v * #w + smult (of_nat q) (#f)"
lemma u: "u = #v * #w + smult (of_nat q) (#f)"
using ex_f[folded some_eq_ex] f_def by auto
lemma t_ex: "∃t :: 'p mod_ring poly. degree (b * f - t * #v) < degree v"
proof-
define v' where "v' ≡ #v :: 'p mod_ring poly"
from monic_v
have 1: "lead_coeff v' = 1" by (simp add: v'_def deg_v)
then have 4: "v' ≠ 0" by auto
obtain t rem :: "'p mod_ring poly"
where "pseudo_divmod (b * f) v' = (t,rem)" by force
from pseudo_divmod[OF 4 this, folded, unfolded 1]
have "b * f = v' * t + rem" and deg: "rem = 0 ∨ degree rem < degree v'" by auto
then have "rem = b * f - t * v'" by(auto simp: ac_simps)
also have "... = b * f - #(#t :: 'p mod_ring poly) * v'" (is "_ = _ - ?t * v'") by simp
also have "... = b * f - ?t * #v"
by (unfold v'_def, rule)
finally have "degree rem = degree ..." by auto
with deg bv have "degree (b * f - ?t * #v :: 'p mod_ring poly) < degree v" by (auto simp: v'_def deg_v)
then show ?thesis by (rule exI)
qed
definition t where "t ≡ SOME t :: 'p mod_ring poly. degree (b * f - t * #v) < degree v"
definition "v' ≡ b * f - t * #v"
definition "w' ≡ a * f + t * #w"
lemma f: "w' * #v + v' * #w = f" (is "?l = _")
proof-
have "?l = f * (a * #v + b * #w :: 'p mod_ring poly)" by (simp add: v'_def w'_def ring_distribs ac_simps)
also
from avbw have "(#(a * #v + b * #w) :: 'p mod_ring poly) = 1" by auto
then have "(a * #v + b * #w :: 'p mod_ring poly) = 1" by auto
finally show ?thesis by auto
qed
lemma degv': "degree v' < degree v" by (unfold v'_def t_def, rule someI_ex, rule t_ex)
lemma degqf[simp]: "degree (smult (of_nat CARD('q)) (#f :: 'pq mod_ring poly)) = degree (#f :: 'pq mod_ring poly)"
proof (intro degree_smult_eqI)
assume "degree (#f :: 'pq mod_ring poly) ≠ 0"
then have f0: "degree f ≠ 0" by simp
moreover define l where "l ≡ lead_coeff f"
ultimately have l0: "l ≠ 0" by auto
then show "of_nat CARD('q) * lead_coeff (#f::'pq mod_ring poly) ≠ 0"
apply (unfold rebase_p_to_pq.lead_coeff_rebase_poly, fold l_def)
apply (transfer)
using q1 by (simp add: pq mod_mod_cancel)
qed
lemma degw': "degree w' ≤ degree w"
proof(rule ccontr)
let ?f = "#f :: 'pq mod_ring poly"
let ?qf = "smult (of_nat q) (#f) :: 'pq mod_ring poly"
have "degree (#w::'p mod_ring poly) ≤ degree w" by (rule degree_rebase_poly_le)
also assume "¬ degree w' ≤ degree w"
then have 1: "degree w < degree w'" by auto
finally have 2: "degree (#w :: 'p mod_ring poly) < degree w'" by auto
then have w'0: "w' ≠ 0" by auto
have 3: "degree (#v * w') = degree (#v :: 'p mod_ring poly) + degree w'"
using monic_v[unfolded] by (intro degree_monic_mult[OF _ w'0], auto simp: deg_v)
have "degree f ≤ degree u"
proof(rule ccontr)
assume "¬?thesis"
then have *: "degree u < degree f" by auto
with degu have 1: "degree v + degree w < degree f" by auto
define lcf where "lcf ≡ lead_coeff f"
with 1 have lcf0: "lcf ≠ 0" by (unfold, auto)
have "degree f = degree ?qf" by simp
also have "... = degree (#v * #w + ?qf)"
proof(rule sym, rule degree_add_eq_right)
from 1 degree_mult_le[of "#v::'pq mod_ring poly" "#w"]
show "degree (#v * #w :: 'pq mod_ring poly) < degree ?qf" by simp
qed
also have "... < degree f" using * u by auto
finally show "False" by auto
qed
with degu have "degree f ≤ degree v + degree w" by auto
also note f[symmetric]
finally have "degree (w' * #v + v' * #w) ≤ degree v + degree w".
moreover have "degree (w' * #v + v' * #w) = degree (w' * #v)"
proof(rule degree_add_eq_left)
have "degree (v' * #w) ≤ degree v' + degree (#w :: 'p mod_ring poly)"
by(rule degree_mult_le)
also have "... < degree v + degree (#w :: 'p mod_ring poly)" using degv' by auto
also have "... < degree (#v :: 'p mod_ring poly) + degree w'" using 2 by (auto simp: deg_v)
also have "... = degree (#v * w')" using 3 by auto
finally show "degree (v' * #w) < degree (w' * #v)" by (auto simp: ac_simps)
qed
ultimately have "degree (w' * #v) ≤ degree v + degree w" by auto
moreover
from 3 have "degree (w' * #v) = degree w' + degree v" by (auto simp: ac_simps deg_v)
with 1 have "degree w + degree v < degree (w' * #v)" by auto
ultimately show False by auto
qed
abbreviation "qv' ≡ smult (of_nat q) (#v') :: 'pq mod_ring poly"
abbreviation "qw' ≡ smult (of_nat q) (#w') :: 'pq mod_ring poly"
abbreviation "V ≡ #v + qv'"
abbreviation "W ≡ #w + qw'"
lemma vV: "v = #V" by (auto simp: v'_def hom_distribs)
lemma wW: "w = #W" by (auto simp: w'_def hom_distribs)
lemma uVW: "u = V * W"
by (subst u, fold f, simp add: ring_distribs add.left_cancel smult_add_right[symmetric] hom_distribs)
lemma degV: "degree V = degree v"
and lcV: "lead_coeff V = @lead_coeff v"
and degW: "degree W = degree w"
proof-
from p1 q1 have "int p < int p * int q" by auto
from less_trans[OF _ this]
have 1: "l < int p ⟹ l < int p * int q" for l by auto
have "degree qv' = degree (#v' :: 'pq mod_ring poly)"
proof (rule degree_smult_eqI, safe, unfold rebase_p_to_pq.degree_rebase_poly_eq)
define l where "l ≡ lead_coeff v'"
assume "degree v' > 0"
then have "lead_coeff v' ≠ 0" by auto
then have "(@l :: 'pq mod_ring) ≠ 0" by (simp add: l_def)
then have "(of_nat q * @l :: 'pq mod_ring) ≠ 0"
apply (transfer fixing:q_ty) using p_dvd_q p1 q1 1 by auto
moreover assume " of_nat q * coeff (#v') (degree v') = (0 :: 'pq mod_ring)"
ultimately show False by (auto simp: l_def)
qed
also from degv' have "... < degree (#v::'pq mod_ring poly)" by simp
finally have *: "degree qv' < degree (#v :: 'pq mod_ring poly)".
from degree_add_eq_left[OF *]
show **: "degree V = degree v" by (simp add: v'_def)
from * have "coeff qv' (degree v) = 0" by (intro coeff_eq_0, auto)
then show "lead_coeff V = @lead_coeff v" by (unfold **, auto simp: v'_def)
with u0 uVW have "degree (V * W) = degree V + degree W"
by (intro degree_mult_eq_left_unit, auto simp: monic_v)
from this[folded uVW, unfolded degu **] show "degree W = degree w" by auto
qed
end
locale Knuth_ex_4_6_2_22_prime = Knuth_ex_4_6_2_22_main ty_p ty_q ty_pq a b u v w
for ty_p :: "'p :: prime_card itself"
and ty_q :: "'q :: nontriv itself"
and ty_pq :: "'pq :: nontriv itself"
and a b u v w +
assumes coprime: "coprime (#v :: 'p mod_ring poly) (#w)"
begin
lemma coprime_preserves: "coprime (#V :: 'p mod_ring poly) (#W)"
apply (intro coprimeI,simp add: rebase_q_to_p.of_nat_CARD_eq_0[simplified] hom_distribs)
using coprime by (elim coprimeE, auto)
lemma pre_unique:
assumes f2: "w'' * #v + v'' * #w = f"
and degv'': "degree v'' < degree v"
shows "v'' = v' ∧ w'' = w'"
proof(intro conjI)
from f f2
have "w' * #v + v' * #w = w'' * #v + v'' * #w" by auto
also have "... - w'' * #v = v'' * #w" by auto
also have "... - v' * #w = (v''- v') * #w" by (auto simp: left_diff_distrib)
finally have *: "(w' - w'') * #v = (v''- v') * #w" by (auto simp: left_diff_distrib)
then have "#v dvd (v'' - v') * #w" by (auto intro: dvdI[of _ _ "w' - w''"] simp: ac_simps)
with coprime have "#v dvd v'' - v'"
by (simp add: coprime_dvd_mult_left_iff)
moreover have "degree (v'' - v') < degree v" by (rule degree_diff_less[OF degv'' degv'])
ultimately have "v'' - v' = 0"
by (metis deg_v degree_0 gr_implies_not_zero poly_divides_conv0)
then show "v'' = v'" by auto
with * have "(w' - w'') * #v = 0" by auto
with bv have "w' - w'' = 0"
by (metis deg_v degree_0 gr_implies_not_zero mult_eq_0_iff)
then show "w'' = w'" by auto
qed
lemma unique:
assumes vV2: "v = #V2" and wW2: "w = #W2" and uVW2: "u = V2 * W2"
and degV2: "degree V2 = degree v" and degW2: "degree W2 = degree w"
and lc: "lead_coeff V2 = @lead_coeff v"
shows "V2 = V" "W2 = W"
proof-
from vV2 have "(#(V2 - #v) :: 'q mod_ring poly) = 0" by (auto simp: hom_distribs)
from rebase_pq_to_q.rebase_poly_eq_0_imp_ex_smult[OF this]
obtain v'' :: "'p mod_ring poly"
where deg: "degree v'' ≤ degree (V2 - #v)"
and v'': "V2 - #v = smult (of_nat CARD('q)) (#v'')" by (elim exE conjE)
then have V2: "V2 = #v + ..." by (metis add_diff_cancel_left' diff_add_cancel)
from lc[unfolded degV2, unfolded V2]
have "of_nat q * (@coeff v'' (degree v) :: 'pq mod_ring) = of_nat q * 0" by auto
from this[unfolded q rebase_pq_to_p.rebase_mult_eq]
have "coeff v'' (degree v) = 0" by simp
moreover have "degree v'' ≤ degree v" using deg degV2
by (metis degree_diff_le le_antisym nat_le_linear rebase_q_to_pq.degree_rebase_poly_eq)
ultimately have degv'': "degree v'' < degree v"
using bv eq_zero_or_degree_less by fastforce
from wW2 have "(#(W2 - #w) :: 'q mod_ring poly) = 0" by (auto simp: hom_distribs)
from rebase_pq_to_q.rebase_poly_eq_0_imp_ex_smult[OF this] pq
obtain w'' :: "'p mod_ring poly" where w'': "W2 - #w = smult (of_nat q) (#w'')" by force
then have W2: "W2 = #w + ..." by (metis add_diff_cancel_left' diff_add_cancel)
have "u = #v * #w + smult (of_nat q) (#w'' * #v + #v'' * #w) + smult (of_nat (q * q)) (#v'' * #w'')"
by(simp add: uVW2 V2 W2 ring_distribs smult_add_right ac_simps)
also have "smult (of_nat (q * q)) (#v'' * #w'' :: 'pq mod_ring poly) = 0" by simp
finally have "u - #v * #w = smult (of_nat q) (#w'' * #v + #v'' * #w)" by auto
also have "u - #v * #w = smult (of_nat q) (#f)" by (subst u, simp)
finally have "w'' * #v + v'' * #w = f" by (simp add: hom_distribs)
from pre_unique[OF this degv'']
have pre: "v'' = v'" "w'' = w'" by auto
with V2 W2 show "V2 = V" "W2 = W" by auto
qed
end
definition
"hensel_1 (ty ::'p :: prime_card itself)
(u :: 'pq :: nontriv mod_ring poly) (v :: 'q :: nontriv mod_ring poly) (w :: 'q mod_ring poly) ≡
if v = 1 then (1,u) else
let (s, t) = bezout_coefficients (#v :: 'p mod_ring poly) (#w) in
let (a, b) = dupe_monic (#v::'p mod_ring poly) (#w) s t 1 in
(Knuth_ex_4_6_2_22_main.V TYPE('q) b u v w, Knuth_ex_4_6_2_22_main.W TYPE('q) a b u v w)"
lemma hensel_1:
fixes u :: "'pq :: nontriv mod_ring poly"
and v w :: "'q :: nontriv mod_ring poly"
assumes "CARD('pq) = CARD('p :: prime_card) * CARD('q)"
and "CARD('p) dvd CARD('q)"
and uvw: "#u = v * w"
and degu: "degree u = degree v + degree w"
and monic: "monic v"
and coprime: "coprime (#v :: 'p mod_ring poly) (#w)"
and out: "hensel_1 TYPE('p) u v w = (V',W')"
shows "u = V' * W' ∧ v = #V' ∧ w = #W' ∧ degree V' = degree v ∧ degree W' = degree w ∧
monic V' ∧ coprime (#V' :: 'p mod_ring poly) (#W')" (is ?main)
and "(∀V'' W''. u = V'' * W'' ⟶ v = #V'' ⟶ w = #W'' ⟶
degree V'' = degree v ⟶ degree W'' = degree w ⟶ lead_coeff V'' = @lead_coeff v ⟶
V'' = V' ∧ W'' = W')" (is "?unique")
proof-
from monic
have degv: "degree (#v :: 'p mod_ring poly) = degree v"
by (simp add: of_int_hom.monic_degree_map_poly_hom)
from monic
have monic2: "monic (#v :: 'p mod_ring poly)"
by (auto simp: degv)
obtain s t where bezout: "bezout_coefficients (#v :: 'p mod_ring poly) (#w) = (s, t)"
by (auto simp add: prod_eq_iff)
then have "s * #v + t * #w = gcd (#v :: 'p mod_ring poly) (#w)"
by (rule bezout_coefficients)
with coprime have vswt: "#v * s + #w * t = 1"
by (simp add: ac_simps)
obtain a b where dupe: "dupe_monic (#v) (#w) s t 1 = (a, b)" by force
from dupe_monic(1,2)[OF vswt monic2, where U=1, unfolded this]
have avbw: "a * #v + b * #w = 1" and degb: "b = 0 ∨ degree b < degree (#v::'p mod_ring poly)" by auto
have "?main ∧ ?unique"
proof (cases "b = 0")
case b0: True
with avbw have "a * #v = 1" by auto
then have "degree (#v :: 'p mod_ring poly) = 0"
by (metis degree_1 degree_mult_eq_0 mult_zero_left one_neq_zero)
from this[unfolded degv] monic_degree_0[OF monic[unfolded]]
have 1: "v = 1" by auto
with b0 out uvw have 2: "V' = 1" "W' = u"
by (unfold split hensel_1_def Let_def dupe) auto
have 3: ?unique apply (simp add: 1 2) by (metis monic_degree_0 mult.left_neutral)
with uvw degu show ?thesis unfolding 1 2 by auto
next
case b0: False
with degb degv have degb: "degree b < degree v" by auto
then have v1: "v ≠ 1" by auto
interpret Knuth_ex_4_6_2_22_prime "TYPE('p)" "TYPE('q)" "TYPE('pq)" a b
by (unfold_locales; fact assms degb avbw)
show ?thesis
proof (intro conjI)
from out [unfolded hensel_1_def] v1
have 1 [simp]: "V' = V" "W' = W" by (auto simp: bezout dupe)
from uVW show "u = V' * W'" by auto
from degV show [simp]: "degree V' = degree v" by simp
from degW show [simp]: "degree W' = degree w" by simp
from lcV have "lead_coeff V' = @lead_coeff v" by simp
with monic_v show "monic V'" by (simp add:)
from vV show "v = #V'" by simp
from wW show "w = #W'" by simp
from coprime_preserves show "coprime (#V' :: 'p mod_ring poly) (#W')" by simp
show 9: ?unique by (unfold 1, intro allI conjI impI; rule unique)
qed
qed
then show ?main ?unique by (fact conjunct1, fact conjunct2)
qed
end
Theory Berlekamp_Hensel
subsection ‹Result is Unique›
text ‹We combine the finite field factorization algorithm with Hensel-lifting to
obtain factorizations mod $p^n$. Moreover, we prove results on unique-factorizations
in mod $p^n$ which admit to extend the uniqueness result for binary Hensel-lifting
to the general case. As a consequence, our factorization algorithm will produce
unique factorizations mod $p^n$.›
theory Berlekamp_Hensel
imports
Finite_Field_Factorization_Record_Based
Hensel_Lifting
begin
hide_const coeff monom
definition berlekamp_hensel :: "int ⇒ nat ⇒ int poly ⇒ int poly list" where
"berlekamp_hensel p n f = (case finite_field_factorization_int p f of
(_,fs) ⇒ hensel_lifting p n f fs)"
text ‹Finite field factorization in combination with Hensel-lifting delivers
factorization modulo $p^k$ where factors are irreducible modulo $p$.
Assumptions: input polynomial is square-free modulo $p$.›
context poly_mod_prime begin
lemma berlekamp_hensel_main:
assumes n: "n ≠ 0"
and res: "berlekamp_hensel p n f = gs"
and cop: "coprime (lead_coeff f) p"
and sf: "square_free_m f"
and berl: "finite_field_factorization_int p f = (c,fs)"
shows "poly_mod.factorization_m (p ^ n) f (lead_coeff f, mset gs) "
and "sort (map degree fs) = sort (map degree gs)"
and "⋀ g. g ∈ set gs ⟹ monic g ∧ poly_mod.Mp (p^n) g = g ∧
poly_mod.irreducible_m p g ∧
poly_mod.degree_m p g = degree g "
proof -
from res[unfolded berlekamp_hensel_def berl split]
have hen: "hensel_lifting p n f fs = gs" .
note bh = finite_field_factorization_int[OF sf berl]
from bh have "poly_mod.factorization_m p f (c, mset fs)" "c ∈ {0..<p}" "(∀fi∈set fs. set (coeffs fi) ⊆ {0..<p})"
by (auto simp: poly_mod.unique_factorization_m_alt_def)
note hen = hensel_lifting[OF n hen cop sf, OF this]
show "poly_mod.factorization_m (p ^ n) f (lead_coeff f, mset gs)"
"sort (map degree fs) = sort (map degree gs)"
"⋀ g. g ∈ set gs ⟹ monic g ∧ poly_mod.Mp (p^n) g = g ∧
poly_mod.irreducible_m p g ∧
poly_mod.degree_m p g = degree g" using hen by auto
qed
theorem berlekamp_hensel:
assumes cop: "coprime (lead_coeff f) p"
and sf: "square_free_m f"
and res: "berlekamp_hensel p n f = gs"
and n: "n ≠ 0"
shows "poly_mod.factorization_m (p^n) f (lead_coeff f, mset gs) "
and "⋀ g. g ∈ set gs ⟹ poly_mod.Mp (p^n) g = g ∧ poly_mod.irreducible_m p g
"
proof -
obtain c fs where "finite_field_factorization_int p f = (c,fs)" by force
from berlekamp_hensel_main[OF n res cop sf this]
show "poly_mod.factorization_m (p^n) f (lead_coeff f, mset gs)"
"⋀ g. g ∈ set gs ⟹ poly_mod.Mp (p^n) g = g ∧ poly_mod.irreducible_m p g" by auto
qed
lemma berlekamp_and_hensel_separated:
assumes cop: "coprime (lead_coeff f) p"
and sf: "square_free_m f"
and res: "hensel_lifting p n f fs = gs"
and berl: "finite_field_factorization_int p f = (c,fs)"
and n: "n ≠ 0"
shows "berlekamp_hensel p n f = gs"
and "sort (map degree fs) = sort (map degree gs)"
proof -
show "berlekamp_hensel p n f = gs" unfolding res[symmetric]
berlekamp_hensel_def hensel_lifting_def berl split Let_def ..
from berlekamp_hensel_main[OF n this cop sf berl] show "sort (map degree fs) = sort (map degree gs)"
by auto
qed
end
lemma prime_cop_exp_poly_mod:
assumes prime: "prime p" and cop: "coprime c p" and n: "n ≠ 0"
shows "poly_mod.M (p^n) c ∈ {1 ..< p^n}"
proof -
from prime have p1: "p > 1" by (simp add: prime_int_iff)
interpret poly_mod_2 "p^n" unfolding poly_mod_2_def using p1 n by simp
from cop p1 m1 have "M c ≠ 0"
by (auto simp add: M_def)
moreover have "M c < p^n" "M c ≥ 0" unfolding M_def using m1 by auto
ultimately show ?thesis by auto
qed
context poly_mod_2
begin
context
fixes p :: int
assumes prime: "prime p"
begin
interpretation p: poly_mod_prime p using prime by unfold_locales
lemma coprime_lead_coeff_factor: assumes "coprime (lead_coeff (f * g)) p"
shows "coprime (lead_coeff f) p" "coprime (lead_coeff g) p"
proof -
{
fix f g
assume cop: "coprime (lead_coeff (f * g)) p"
from this[unfolded lead_coeff_mult]
have "coprime (lead_coeff f) p" using prime
by simp
}
from this[OF assms] this[of g f] assms
show "coprime (lead_coeff f) p" "coprime (lead_coeff g) p" by (auto simp: ac_simps)
qed
lemma unique_factorization_m_factor: assumes uf: "unique_factorization_m (f * g) (c,hs)"
and cop: "coprime (lead_coeff (f * g)) p"
and sf: "p.square_free_m (f * g)"
and n: "n ≠ 0"
and m: "m = p^n"
shows "∃ fs gs. unique_factorization_m f (lead_coeff f,fs)
∧ unique_factorization_m g (lead_coeff g,gs)
∧ Mf (c,hs) = Mf (lead_coeff f * lead_coeff g, fs + gs)
∧ image_mset Mp fs = fs ∧ image_mset Mp gs = gs"
proof -
from prime have p1: "1 < p" by (simp add: prime_int_iff)
interpret p: poly_mod_2 p by (standard, rule p1)
note sf = p.square_free_m_factor[OF sf]
note cop = coprime_lead_coeff_factor[OF cop]
from cop have copm: "coprime (lead_coeff f) m" "coprime (lead_coeff g) m"
by (simp_all add: m)
have df: "degree_m f = degree f"
by (rule degree_m_eq[OF _ m1], insert copm(1) m1, auto)
have dg: "degree_m g = degree g"
by (rule degree_m_eq[OF _ m1], insert copm(2) m1, auto)
define fs where "fs ≡ mset (berlekamp_hensel p n f)"
define gs where "gs ≡ mset (berlekamp_hensel p n g)"
from p.berlekamp_hensel[OF cop(1) sf(1) refl n, folded m]
have f: "factorization_m f (lead_coeff f,fs)"
and f_id: "⋀ f. f ∈# fs ⟹ Mp f = f" unfolding fs_def by auto
from p.berlekamp_hensel[OF cop(2) sf(2) refl n, folded m]
have g: "factorization_m g (lead_coeff g,gs)"
and g_id: "⋀ f. f ∈# gs ⟹ Mp f = f" unfolding gs_def by auto
from factorization_m_prod[OF f g] uf[unfolded unique_factorization_m_alt_def]
have eq: "Mf (lead_coeff f * lead_coeff g, fs + gs) = Mf (c,hs)" by blast
have uff: "unique_factorization_m f (lead_coeff f,fs)"
proof (rule unique_factorization_mI[OF f])
fix e ks
assume "factorization_m f (e,ks)"
from factorization_m_prod[OF this g] uf[unfolded unique_factorization_m_alt_def]
factorization_m_lead_coeff[OF this, unfolded degree_m_eq_lead_coeff[OF df]]
have "Mf (e * lead_coeff g, ks + gs) = Mf (c,hs)" and e: "M (lead_coeff f) = M e" by blast+
from this[folded eq, unfolded Mf_def split]
have ks: "image_mset Mp ks = image_mset Mp fs" by auto
show "Mf (e, ks) = Mf (lead_coeff f, fs)" unfolding Mf_def split ks e by simp
qed
have idf: "image_mset Mp fs = fs" using f_id by (induct fs, auto)
have idg: "image_mset Mp gs = gs" using g_id by (induct gs, auto)
have ufg: "unique_factorization_m g (lead_coeff g,gs)"
proof (rule unique_factorization_mI[OF g])
fix e ks
assume "factorization_m g (e,ks)"
from factorization_m_prod[OF f this] uf[unfolded unique_factorization_m_alt_def]
factorization_m_lead_coeff[OF this, unfolded degree_m_eq_lead_coeff[OF dg]]
have "Mf (lead_coeff f * e, fs + ks) = Mf (c,hs)" and e: "M (lead_coeff g) = M e" by blast+
from this[folded eq, unfolded Mf_def split]
have ks: "image_mset Mp ks = image_mset Mp gs" by auto
show "Mf (e, ks) = Mf (lead_coeff g, gs)" unfolding Mf_def split ks e by simp
qed
from uff ufg eq[symmetric] idf idg show ?thesis by auto
qed
lemma unique_factorization_factorI:
assumes ufact: "unique_factorization_m (f * g) FG"
and cop: "coprime (lead_coeff (f * g)) p"
and sf: "poly_mod.square_free_m p (f * g)"
and n: "n ≠ 0"
and m: "m = p^n"
shows "factorization_m f F ⟹ unique_factorization_m f F"
and "factorization_m g G ⟹ unique_factorization_m g G"
proof -
obtain c fg where FG: "FG = (c,fg)" by force
from unique_factorization_m_factor[OF ufact[unfolded FG] cop sf n m]
obtain fs gs where ufact: "unique_factorization_m f (lead_coeff f, fs)"
"unique_factorization_m g (lead_coeff g, gs)" by auto
from ufact(1) show "factorization_m f F ⟹ unique_factorization_m f F"
by (metis unique_factorization_m_alt_def)
from ufact(2) show "factorization_m g G ⟹ unique_factorization_m g G"
by (metis unique_factorization_m_alt_def)
qed
end
lemma monic_Mp_prod_mset: assumes fs: "⋀ f. f ∈# fs ⟹ monic (Mp f)"
shows "monic (Mp (prod_mset fs))"
proof -
have "monic (prod_mset (image_mset Mp fs))"
by (rule monic_prod_mset, insert fs, auto)
from monic_Mp[OF this] have "monic (Mp (prod_mset (image_mset Mp fs)))" .
also have "Mp (prod_mset (image_mset Mp fs)) = Mp (prod_mset fs)" by (rule Mp_prod_mset)
finally show ?thesis .
qed
lemma degree_Mp_mult_monic: assumes "monic f" "monic g"
shows "degree (Mp (f * g)) = degree f + degree g"
by (metis zero_neq_one assms degree_monic_mult leading_coeff_0_iff monic_degree_m monic_mult)
lemma factorization_m_degree: assumes "factorization_m f (c,fs)"
and 0: "Mp f ≠ 0"
shows "degree_m f = sum_mset (image_mset degree_m fs)"
proof -
note a = assms[unfolded factorization_m_def split]
hence deg: "degree_m f = degree_m (smult c (prod_mset fs))"
and fs: "⋀ f. f ∈# fs ⟹ monic (Mp f)" by auto
define gs where "gs ≡ Mp (prod_mset fs)"
from monic_Mp_prod_mset[OF fs] have mon_gs: "monic gs" unfolding gs_def .
have d:"degree (Mp (Polynomial.smult c gs)) = degree gs"
proof -
have f1: "0 ≠ c" by (metis "0" Mp_0 a(1) smult_eq_0_iff)
then have "M c ≠ 0" by (metis (no_types) "0" assms(1) factorization_m_lead_coeff leading_coeff_0_iff)
then show "degree (Mp (Polynomial.smult c gs)) = degree gs"
unfolding monic_degree_m[OF mon_gs,symmetric]
using f1 by (metis coeff_smult degree_m_eq degree_smult_eq m1 mon_gs monic_degree_m mult_cancel_left1 poly_mod.M_def)
qed
note deg
also have "degree_m (smult c (prod_mset fs)) = degree_m (smult c gs)"
unfolding gs_def by simp
also have "… = degree gs" using d.
also have "… = sum_mset (image_mset degree_m fs)" unfolding gs_def
using fs
proof (induct fs)
case (add f fs)
have mon: "monic (Mp f)" "monic (Mp (prod_mset fs))" using monic_Mp_prod_mset[of fs]
add(2) by auto
have "degree (Mp (prod_mset (add_mset f fs))) = degree (Mp (Mp f * Mp (prod_mset fs)))"
by (auto simp: ac_simps)
also have "… = degree (Mp f) + degree (Mp (prod_mset fs))"
by (rule degree_Mp_mult_monic[OF mon])
also have "degree (Mp (prod_mset fs)) = sum_mset (image_mset degree_m fs)"
by (rule add(1), insert add(2), auto)
finally show ?case by (simp add: ac_simps)
qed simp
finally show ?thesis .
qed
lemma degree_m_mult_le: "degree_m (f * g) ≤ degree_m f + degree_m g"
using degree_m_mult_le by auto
lemma degree_m_prod_mset_le: "degree_m (prod_mset fs) ≤ sum_mset (image_mset degree_m fs)"
proof (induct fs)
case empty
show ?case by simp
next
case (add f fs)
then show ?case using degree_m_mult_le[of f "prod_mset fs"] by auto
qed
end
context poly_mod_prime
begin
lemma unique_factorization_m_factor_partition: assumes l0: "l ≠ 0"
and uf: "poly_mod.unique_factorization_m (p^l) f (lead_coeff f, mset gs)"
and f: "f = f1 * f2"
and cop: "coprime (lead_coeff f) p"
and sf: "square_free_m f"
and part: "List.partition (λgi. gi dvdm f1) gs = (gs1, gs2)"
shows "poly_mod.unique_factorization_m (p^l) f1 (lead_coeff f1, mset gs1)"
"poly_mod.unique_factorization_m (p^l) f2 (lead_coeff f2, mset gs2)"
proof -
interpret pl: poly_mod_2 "p^l" by (standard, insert m1 l0, auto)
let ?I = "image_mset pl.Mp"
note Mp_pow [simp] = Mp_Mp_pow_is_Mp[OF l0 m1]
have [simp]: "pl.Mp x dvdm u = (x dvdm u)" for x u unfolding dvdm_def using Mp_pow[of x]
by (metis poly_mod.mult_Mp(1))
have gs_split: "set gs = set gs1 ∪ set gs2" using part by auto
from pl.unique_factorization_m_factor[OF prime uf[unfolded f] _ _ l0 refl, folded f, OF cop sf]
obtain hs1 hs2 where uf': "pl.unique_factorization_m f1 (lead_coeff f1, hs1)"
"pl.unique_factorization_m f2 (lead_coeff f2, hs2)"
and gs_hs: "?I (mset gs) = hs1 + hs2"
unfolding pl.Mf_def split by auto
have gs_gs: "?I (mset gs) = ?I (mset gs1) + ?I (mset gs2)" using part
by (auto, induct gs arbitrary: gs1 gs2, auto)
with gs_hs have gs_hs12: "?I (mset gs1) + ?I (mset gs2) = hs1 + hs2" by auto
note pl_dvdm_imp_p_dvdm = pl_dvdm_imp_p_dvdm[OF l0]
note fact = pl.unique_factorization_m_imp_factorization[OF uf]
have gs1: "?I (mset gs1) = {#x ∈# ?I (mset gs). x dvdm f1#}"
using part by (auto, induct gs arbitrary: gs1 gs2, auto)
also have "… = {#x ∈# hs1. x dvdm f1#} + {#x ∈# hs2. x dvdm f1#}" unfolding gs_hs by simp
also have "{#x ∈# hs2. x dvdm f1#} = {#}"
proof (rule ccontr)
assume "¬ ?thesis"
then obtain x where x: "x ∈# hs2" and dvd: "x dvdm f1" by fastforce
from x gs_hs have "x ∈# ?I (mset gs)" by auto
with fact[unfolded pl.factorization_m_def]
have xx: "pl.irreducible⇩d_m x" "monic x" by auto
from square_free_m_prod_imp_coprime_m[OF sf[unfolded f]]
have cop_h_f: "coprime_m f1 f2" by auto
from pl.factorization_m_mem_dvdm[OF pl.unique_factorization_m_imp_factorization[OF uf'(2)], of x] x
have "pl.dvdm x f2" by auto
hence "x dvdm f2" by (rule pl_dvdm_imp_p_dvdm)
from cop_h_f[unfolded coprime_m_def, rule_format, OF dvd this]
have "x dvdm 1" by auto
from dvdm_imp_degree_le[OF this xx(2) _ m1] have "degree x = 0" by auto
with xx show False unfolding pl.irreducible⇩d_m_def by auto
qed
also have "{#x ∈# hs1. x dvdm f1#} = hs1"
proof (rule ccontr)
assume "¬ ?thesis"
from filter_mset_inequality[OF this]
obtain x where x: "x ∈# hs1" and dvd: "¬ x dvdm f1" by blast
from pl.factorization_m_mem_dvdm[OF pl.unique_factorization_m_imp_factorization[OF uf'(1)],
of x] x dvd
have "pl.dvdm x f1" by auto
from pl_dvdm_imp_p_dvdm[OF this] dvd show False by auto
qed
finally have gs_hs1: "?I (mset gs1) = hs1" by simp
with gs_hs12 have "?I (mset gs2) = hs2" by auto
with uf' gs_hs1 have "pl.unique_factorization_m f1 (lead_coeff f1, ?I (mset gs1))"
"pl.unique_factorization_m f2 (lead_coeff f2, ?I (mset gs2))" by auto
thus "pl.unique_factorization_m f1 (lead_coeff f1, mset gs1)"
"pl.unique_factorization_m f2 (lead_coeff f2, mset gs2)"
unfolding pl.unique_factorization_m_def
by (auto simp: pl.Mf_def image_mset.compositionality o_def)
qed
lemma factorization_pn_to_factorization_p: assumes fact: "poly_mod.factorization_m (p^n) C (c,fs)"
and sf: "square_free_m C"
and n: "n ≠ 0"
shows "factorization_m C (c,fs)"
proof -
let ?q = "p^n"
from n m1 have q: "?q > 1" by simp
interpret q: poly_mod_2 ?q by (standard, insert q, auto)
from fact[unfolded q.factorization_m_def]
have eq: "q.Mp C = q.Mp (Polynomial.smult c (prod_mset fs))"
and irr: "⋀ f. f ∈# fs ⟹ q.irreducible⇩d_m f"
and mon: "⋀ f. f ∈# fs ⟹ monic (q.Mp f)"
by auto
from arg_cong[OF eq, of Mp]
have eq: "eq_m C (smult c (prod_mset fs))"
by (simp add: Mp_Mp_pow_is_Mp m1 n)
show ?thesis unfolding factorization_m_def split
proof (rule conjI[OF eq], intro ballI conjI)
fix f
assume f: "f ∈# fs"
from mon[OF this] have mon_qf: "monic (q.Mp f)" .
hence lc: "lead_coeff (q.Mp f) = 1" by auto
from mon_qf show mon_f: "monic (Mp f)"
by (metis Mp_Mp_pow_is_Mp m1 monic_Mp n)
from irr[OF f] have irr: "q.irreducible⇩d_m f" .
hence "q.degree_m f ≠ 0" unfolding q.irreducible⇩d_m_def by auto
also have "q.degree_m f = degree_m f" using mon[OF f]
by (metis Mp_Mp_pow_is_Mp m1 monic_degree_m n)
finally have deg: "degree_m f ≠ 0" by auto
from f obtain gs where fs: "fs = {#f#} + gs"
by (metis mset_subset_eq_single subset_mset.add_diff_inverse)
from eq[unfolded fs] have "Mp C = Mp (f * smult c (prod_mset gs))" by auto
from square_free_m_factor[OF square_free_m_cong[OF sf this]]
have sf_f: "square_free_m f" by simp
have sf_Mf: "square_free_m (q.Mp f)"
by (rule square_free_m_cong[OF sf_f], auto simp: Mp_Mp_pow_is_Mp n m1)
have "coprime (lead_coeff (q.Mp f)) p" using mon[OF f] prime by simp
from berlekamp_hensel[OF this sf_Mf refl n, unfolded lc] obtain gs where
qfact: "q.factorization_m (q.Mp f) (1, mset gs)"
and "⋀ g. g ∈ set gs ⟹ irreducible_m g" by blast
hence fact: "q.Mp f = q.Mp (prod_list gs)"
and gs: "⋀ g. g∈ set gs ⟹ irreducible⇩d_m g ∧ q.irreducible⇩d_m g ∧ monic (q.Mp g)"
unfolding q.factorization_m_def by auto
from q.factorization_m_degree[OF qfact]
have deg: "q.degree_m (q.Mp f) = sum_mset (image_mset q.degree_m (mset gs))"
using mon_qf by fastforce
from irr[unfolded q.irreducible⇩d_m_def]
have "sum_mset (image_mset q.degree_m (mset gs)) ≠ 0" by (fold deg, auto)
then obtain g gs' where gs1: "gs = g # gs'" by (cases gs, auto)
{
assume "gs' ≠ []"
then obtain h hs where gs2: "gs' = h # hs" by (cases gs', auto)
from deg gs[unfolded q.irreducible⇩d_m_def]
have small: "q.degree_m g < q.degree_m f"
"q.degree_m h + sum_mset (image_mset q.degree_m (mset hs)) < q.degree_m f"
unfolding gs1 gs2 by auto
have "q.eq_m f (g * (h * prod_list hs))"
using fact unfolding gs1 gs2 by simp
with irr[unfolded q.irreducible⇩d_m_def, THEN conjunct2, rule_format, of g "h * prod_list hs"]
small(1) have "¬ q.degree_m (h * prod_list hs) < q.degree_m f" by auto
hence "q.degree_m f ≤ q.degree_m (h * prod_list hs)" by simp
also have "… = q.degree_m (prod_mset ({#h#} + mset hs))" by simp
also have "… ≤ sum_mset (image_mset q.degree_m ({#h#} + mset hs))"
by (rule q.degree_m_prod_mset_le)
also have "… < q.degree_m f" using small(2) by simp
finally have False by simp
}
hence gs1: "gs = [g]" unfolding gs1 by (cases gs', auto)
with fact have "q.Mp f = q.Mp g" by auto
from arg_cong[OF this, of Mp] have eq: "Mp f = Mp g"
by (simp add: Mp_Mp_pow_is_Mp m1 n)
from gs[unfolded gs1] have g: "irreducible⇩d_m g" by auto
with eq show "irreducible⇩d_m f" unfolding irreducible⇩d_m_def by auto
qed
qed
lemma unique_monic_hensel_factorization:
assumes ufact: "unique_factorization_m C (1,Fs)"
and C: "monic C" "square_free_m C"
and n: "n ≠ 0"
shows "∃ Gs. poly_mod.unique_factorization_m (p^n) C (1, Gs)"
using ufact C
proof (induct Fs arbitrary: C rule: wf_induct[OF wf_measure[of size]])
case (1 Fs C)
let ?q = "p^n"
from n m1 have q: "?q > 1" by simp
interpret q: poly_mod_2 ?q by (standard, insert q, auto)
note [simp] = Mp_Mp_pow_is_Mp[OF n m1]
note IH = 1(1)[rule_format]
note ufact = 1(2)
hence fact: "factorization_m C (1, Fs)" unfolding unique_factorization_m_alt_def by auto
note monC = 1(3)
note sf = 1(4)
let ?n = "size Fs"
{
fix d gs
assume qfact: "q.factorization_m C (d,gs)"
from q.factorization_m_lead_coeff[OF this] q.monic_Mp[OF monC]
have d1: "q.M d = 1" by auto
from factorization_pn_to_factorization_p[OF qfact sf n]
have "factorization_m C (d,gs)" .
with ufact d1 have "q.M d = 1" "M d = 1" "image_mset Mp gs = image_mset Mp Fs"
unfolding unique_factorization_m_alt_def Mf_def by auto
} note pre_unique = this
show ?case
proof (cases Fs)
case empty
with fact C have "Mp C = 1" unfolding factorization_m_def by auto
hence "degree (Mp C) = 0" by simp
with degree_m_eq_monic[OF monC m1] have "degree C = 0" by simp
with monC have C1: "C = 1" using monic_degree_0 by blast
with fact have fact: "q.factorization_m C (1,{#})"
by (auto simp: q.factorization_m_def)
show ?thesis
proof (rule exI, rule q.unique_factorization_mI[OF fact])
fix d gs
assume fact: "q.factorization_m C (d,gs)"
from pre_unique[OF this, unfolded empty]
show "q.Mf (d, gs) = q.Mf (1, {#})" by (auto simp: q.Mf_def)
qed
next
case (add D H) note FDH = this
let ?D = "Mp D"
let ?H = "Mp (prod_mset H)"
from fact have monFs: "⋀ F. F ∈# Fs ⟹ monic (Mp F)"
and prod: "eq_m C (prod_mset Fs)" unfolding factorization_m_def by auto
hence monD: "monic ?D" unfolding FDH by auto
from square_free_m_cong[OF sf, of "D * prod_mset H"] prod[unfolded FDH]
have "square_free_m (D * prod_mset H)" by (auto simp: ac_simps)
from square_free_m_prod_imp_coprime_m[OF this]
have "coprime_m D (prod_mset H)" .
hence cop': "coprime_m ?D ?H" unfolding coprime_m_def dvdm_def Mp_Mp by simp
from fact have eq': "eq_m (?D * ?H) C"
unfolding FDH by (simp add: factorization_m_def ac_simps)
note unique_hensel_binary[OF prime cop' eq' Mp_Mp Mp_Mp monD n]
from ex1_implies_ex[OF this] this
obtain A B where CAB: "q.eq_m (A * B) C" and monA: "monic A" and DA: "eq_m ?D A"
and HB: "eq_m ?H B" and norm: "q.Mp A = A" "q.Mp B = B"
and unique: "⋀ D' H'. q.eq_m (D' * H') C ⟹
monic D' ⟹
eq_m (Mp D) D' ⟹ eq_m (Mp (prod_mset H)) H' ⟹ q.Mp D' = D' ⟹ q.Mp H' = H'
⟹ D' = A ∧ H' = B" by blast
note hensel_bin_wit = CAB monA DA HB norm
from monA have monA': "monic (q.Mp A)" by (rule q.monic_Mp)
from q.monic_Mp[OF monC] CAB have monicP:"monic (q.Mp (A * B))" by auto
have f4: "⋀p. coeff (A * p) (degree (A * p)) = coeff p (degree p)"
by (simp add: coeff_degree_mult monA)
have f2: "⋀p n i. coeff p n mod i = coeff (poly_mod.Mp i p) n"
using poly_mod.M_def poly_mod.Mp_coeff by presburger
hence "coeff B (degree B) = 0 ∨ monic B"
using monicP f4 by (metis (no_types) norm(2) q.degree_m_eq q.m1)
hence monB: "monic B"
using f4 monicP by (metis norm(2) leading_coeff_0_iff)
from monA monB have lcAB: "lead_coeff (A * B) = 1" by (rule monic_mult)
hence copAB: "coprime (lead_coeff (A * B)) p" by auto
from arg_cong[OF CAB, of Mp]
have CAB': "eq_m C (A * B)" by auto
from sf CAB' have sfAB: "square_free_m (A * B)" using square_free_m_cong by blast
from CAB' ufact have ufact: "unique_factorization_m (A * B) (1, Fs)"
using unique_factorization_m_cong by blast
have "(1 :: nat) ≠ 0" "p = p ^ 1" by auto
note u_factor = unique_factorization_factorI[OF prime ufact copAB sfAB this]
from fact DA have "irreducible⇩d_m D" "eq_m A D" unfolding add factorization_m_def by auto
hence "irreducible⇩d_m A" using Mp_irreducible⇩d_m by fastforce
from irreducible⇩d_lifting[OF n _ this] have irrA: "q.irreducible⇩d_m A" using monA
by (simp add: m1 poly_mod.degree_m_eq_monic q.m1)
from add have lenH: "(H,Fs) ∈ measure size" by auto
from HB fact have factB: "factorization_m B (1, H)"
unfolding FDH factorization_m_def by auto
from u_factor(2)[OF factB] have ufactB: "unique_factorization_m B (1, H)" .
from sfAB have sfB: "square_free_m B" by (rule square_free_m_factor)
from IH[OF lenH ufactB monB sfB] obtain Bs where
IH2: "q.unique_factorization_m B (1, Bs)" by auto
from CAB have "q.Mp C = q.Mp (q.Mp A * q.Mp B)" by simp
also have "q.Mp A * q.Mp B = q.Mp A * q.Mp (prod_mset Bs)"
using IH2 unfolding q.unique_factorization_m_alt_def q.factorization_m_def by auto
also have "q.Mp … = q.Mp (A * prod_mset Bs)" by simp
finally have factC: "q.factorization_m C (1, {# A #} + Bs)" using IH2 monA' irrA
by (auto simp: q.unique_factorization_m_alt_def q.factorization_m_def)
show ?thesis
proof (rule exI, rule q.unique_factorization_mI[OF factC])
fix d gs
assume dgs: "q.factorization_m C (d,gs)"
from pre_unique[OF dgs, unfolded add] have d1: "q.M d = 1" and
gs_fs: "image_mset Mp gs = {# Mp D #} + image_mset Mp H" by (auto simp: ac_simps)
have "∀f m p ma. image_mset f m ≠ add_mset (p::int poly) ma ∨
(∃mb pa. m = add_mset (pa::int poly) mb ∧ f pa = p ∧ image_mset f mb = ma)"
by (simp add: msed_map_invR)
then obtain g hs where gs: "gs = {# g #} + hs" and gD: "Mp g = Mp D"
and hsH: "image_mset Mp hs = image_mset Mp H"
using gs_fs by (metis add_mset_add_single union_commute)
from dgs[unfolded q.factorization_m_def split]
have eq: "q.Mp C = q.Mp (smult d (prod_mset gs))"
and irr_mon: "⋀ g. g∈#gs ⟹ q.irreducible⇩d_m g ∧ monic (q.Mp g)"
using d1 by auto
note eq
also have "q.Mp (smult d (prod_mset gs)) = q.Mp (smult (q.M d) (prod_mset gs))"
by simp
also have "… = q.Mp (prod_mset gs)" unfolding d1 by simp
finally have eq: "q.eq_m (q.Mp g * q.Mp (prod_mset hs)) C" unfolding gs by simp
from gD have Dg: "eq_m (Mp D) (q.Mp g)" by simp
have "Mp (prod_mset H) = Mp (prod_mset (image_mset Mp H))" by simp
also have "… = Mp (prod_mset hs)" unfolding hsH[symmetric] by simp
finally have Hhs: "eq_m (Mp (prod_mset H)) (q.Mp (prod_mset hs))" by simp
from irr_mon[of g, unfolded gs] have mon_g: "monic (q.Mp g)" by auto
from unique[OF eq mon_g Dg Hhs q.Mp_Mp q.Mp_Mp]
have gA: "q.Mp g = A" and hsB: "q.Mp (prod_mset hs) = B" by auto
have "q.factorization_m B (1, hs)" unfolding q.factorization_m_def split
by (simp add: hsB norm irr_mon[unfolded gs])
with IH2 have hsBs: "q.Mf (1,hs) = q.Mf (1,Bs)" unfolding q.unique_factorization_m_alt_def by blast
show "q.Mf (d, gs) = q.Mf (1, {# A #} + Bs)"
using gA hsBs d1 unfolding gs q.Mf_def by auto
qed
qed
qed
theorem berlekamp_hensel_unique:
assumes cop: "coprime (lead_coeff f) p"
and sf: "poly_mod.square_free_m p f"
and res: "berlekamp_hensel p n f = gs"
and n: "n ≠ 0"
shows "poly_mod.unique_factorization_m (p^n) f (lead_coeff f, mset gs) "
"⋀ g. g ∈ set gs ⟹ poly_mod.Mp (p^n) g = g "
proof -
let ?q = "p^n"
interpret q: poly_mod_2 ?q unfolding poly_mod_2_def using m1 n by simp
from berlekamp_hensel[OF assms]
have bh_fact: "q.factorization_m f (lead_coeff f, mset gs)" by auto
from berlekamp_hensel[OF assms]
show "⋀ g. g ∈ set gs ⟹ poly_mod.Mp (p^n) g = g" by blast
from prime have p1: "p > 1" by (simp add: prime_int_iff)
let ?lc = "coeff f (degree f)"
define ilc where "ilc ≡ inverse_mod ?lc (p ^ n)"
from cop p1 n have inv: "q.M (ilc * ?lc) = 1"
by (auto simp add: q.M_def ilc_def inverse_mod_pow)
hence ilc0: "ilc ≠ 0" by (cases "ilc = 0", auto)
{
fix q
assume "ilc * ?lc = ?q * q"
from arg_cong[OF this, of q.M] have "q.M (ilc * ?lc) = 0"
unfolding q.M_def by auto
with inv have False by auto
} note not_dvd = this
let ?in = "q.Mp (smult ilc f)"
have mon: "monic ?in" unfolding q.Mp_coeff coeff_smult
by (subst q.degree_m_eq[OF _ q.m1], insert not_dvd, auto simp: inv ilc0)
have "q.Mp f = q.Mp (smult (q.M (?lc * ilc)) f)" using inv by (simp add: ac_simps)
also have "… = q.Mp (smult ?lc (smult ilc f))" by simp
finally have f: "q.Mp f = q.Mp (smult ?lc (smult ilc f))" .
from arg_cong[OF f, of Mp]
have "Mp f = Mp (smult ?lc (smult ilc f))"
by (simp add: Mp_Mp_pow_is_Mp n p1)
from arg_cong[OF this, of square_free_m, unfolded Mp_square_free_m] sf
have "square_free_m (smult (coeff f (degree f)) (smult ilc f))" by simp
from square_free_m_smultD[OF this] have sf: "square_free_m (smult ilc f)" .
have Mp_in: "Mp ?in = Mp (smult ilc f)"
by (simp add: Mp_Mp_pow_is_Mp n p1)
from Mp_square_free_m[of ?in, unfolded Mp_in] sf have sf: "square_free_m ?in"
unfolding Mp_square_free_m by simp
obtain a b where "finite_field_factorization_int p ?in = (a,b)" by force
from finite_field_factorization_int[OF sf this]
have ufact: "unique_factorization_m ?in (a, mset b)" by auto
from unique_factorization_m_imp_factorization[OF this]
have fact: "factorization_m ?in (a, mset b)" .
from factorization_m_lead_coeff[OF this] monic_Mp[OF mon]
have "M a = 1" by auto
with ufact have "unique_factorization_m ?in (1, mset b)"
unfolding unique_factorization_m_def Mf_def by auto
from unique_monic_hensel_factorization[OF this mon sf n]
obtain hs where "q.unique_factorization_m ?in (1, hs)" by auto
hence unique: "q.unique_factorization_m (smult ilc f) (1, hs)"
unfolding unique_factorization_m_def Mf_def by auto
from q.factorization_m_smult[OF q.unique_factorization_m_imp_factorization[OF unique], of ?lc]
have "q.factorization_m (smult (ilc * ?lc) f) (?lc, hs)" by (simp add: ac_simps)
moreover have "q.Mp (smult (q.M (ilc * ?lc)) f) = q.Mp f" unfolding inv by simp
ultimately have fact: "q.factorization_m f (?lc, hs)"
unfolding q.factorization_m_def by auto
have "q.unique_factorization_m f (?lc, hs)"
proof (rule q.unique_factorization_mI[OF fact])
fix d us
assume other_fact: "q.factorization_m f (d,us)"
from q.factorization_m_lead_coeff[OF this] have lc: "q.M d = lead_coeff (q.Mp f)" ..
have lc: "q.M d = q.M ?lc" unfolding lc
by (metis bh_fact q.factorization_m_lead_coeff)
from q.factorization_m_smult[OF other_fact, of ilc] unique
have eq: "q.Mf (d * ilc, us) = q.Mf (1, hs)" unfolding q.unique_factorization_m_def by auto
thus "q.Mf (d, us) = q.Mf (?lc, hs)" using lc unfolding q.Mf_def by auto
qed
with bh_fact show "q.unique_factorization_m f (lead_coeff f, mset gs)"
unfolding q.unique_factorization_m_alt_def by metis
qed
lemma hensel_lifting_unique:
assumes n: "n ≠ 0"
and res: "hensel_lifting p n f fs = gs"
and cop: "coprime (lead_coeff f) p"
and sf: "poly_mod.square_free_m p f"
and fact: "poly_mod.factorization_m p f (c, mset fs)"
and c: "c ∈ {0..<p}"
and norm: "(∀fi∈set fs. set (coeffs fi) ⊆ {0..<p})"
shows "poly_mod.unique_factorization_m (p^n) f (lead_coeff f, mset gs)"
"sort (map degree fs) = sort (map degree gs)"
"⋀ g. g ∈ set gs ⟹ monic g ∧ poly_mod.Mp (p^n) g = g ∧
poly_mod.irreducible_m p g ∧
poly_mod.degree_m p g = degree g "
proof -
note hensel = hensel_lifting[OF assms]
show "sort (map degree fs) = sort (map degree gs)"
"⋀ g. g ∈ set gs ⟹ monic g ∧ poly_mod.Mp (p^n) g = g ∧
poly_mod.irreducible_m p g ∧
poly_mod.degree_m p g = degree g" using hensel by auto
from berlekamp_hensel_unique[OF cop sf refl n]
have "poly_mod.unique_factorization_m (p ^ n) f (lead_coeff f, mset (berlekamp_hensel p n f))" by auto
with hensel(1) show "poly_mod.unique_factorization_m (p^n) f (lead_coeff f, mset gs)"
by (metis poly_mod.unique_factorization_m_alt_def)
qed
end
end
Theory Square_Free_Int_To_Square_Free_GFp
section ‹Reconstructing Factors of Integer Polynomials›
subsection ‹Square-Free Polynomials over Finite Fields and Integers›
theory Square_Free_Int_To_Square_Free_GFp
imports
Subresultants.Subresultant_Gcd
Polynomial_Factorization.Rational_Factorization
Finite_Field
Polynomial_Factorization.Square_Free_Factorization
begin
lemma square_free_int_rat: assumes sf: "square_free f"
shows "square_free (map_poly rat_of_int f)"
proof -
let ?r = "map_poly rat_of_int"
from sf[unfolded square_free_def] have f0: "f ≠ 0" "⋀ q. degree q ≠ 0 ⟹ ¬ q * q dvd f" by auto
show ?thesis
proof (rule square_freeI)
show "?r f ≠ 0" using f0 by auto
fix q
assume dq: "degree q > 0" and dvd: "q * q dvd ?r f"
hence q0: "q ≠ 0" by auto
obtain q' c where norm: "rat_to_normalized_int_poly q = (c,q')" by force
from rat_to_normalized_int_poly[OF norm] have c0: "c ≠ 0" by auto
note q = rat_to_normalized_int_poly(1)[OF norm]
from dvd obtain k where rf: "?r f = q * (q * k)" unfolding dvd_def by (auto simp: ac_simps)
from rat_to_int_factor_explicit[OF this norm] obtain s where
f: "f = q' * smult (content f) s" by auto
let ?s = "smult (content f) s"
from arg_cong[OF f, of ?r] c0
have "?r f = q * (smult (inverse c) (?r ?s))"
by (simp add: field_simps q hom_distribs)
from arg_cong[OF this[unfolded rf], of "λ f. f div q"] q0
have "q * k = smult (inverse c) (?r ?s)"
by (metis nonzero_mult_div_cancel_left)
from arg_cong[OF this, of "smult c"] have "?r ?s = q * smult c k" using c0
by (auto simp: field_simps)
from rat_to_int_factor_explicit[OF this norm] obtain t where "?s = q' * t" by blast
from f[unfolded this] sf[unfolded square_free_def] f0 have "degree q' = 0" by auto
with rat_to_normalized_int_poly(4)[OF norm] dq show False by auto
qed
qed
lemma content_free_unit:
assumes "content (p::'a::{idom,semiring_gcd} poly) = 1"
shows "p dvd 1 ⟷ degree p = 0"
by (insert assms, auto dest!:degree0_coeffs simp: normalize_1_iff poly_dvd_1)
lemma square_free_imp_resultant_non_zero: assumes sf: "square_free (f :: int poly)"
shows "resultant f (pderiv f) ≠ 0"
proof (cases "degree f = 0")
case True
from degree0_coeffs[OF this] obtain c where f: "f = [:c:]" by auto
with sf have c: "c ≠ 0" unfolding square_free_def by auto
show ?thesis unfolding f by simp
next
case False note deg = this
define pp where "pp = primitive_part f"
define c where "c = content f"
from sf have f0: "f ≠ 0" unfolding square_free_def by auto
hence c0: "c ≠ 0" unfolding c_def by auto
have f: "f = smult c pp" unfolding c_def pp_def unfolding content_times_primitive_part[of f] ..
from sf[unfolded f] c0 have sf': "square_free pp" by (metis dvd_smult smult_0_right square_free_def)
from deg[unfolded f] c0 have deg': "⋀ x. degree pp > 0 ∨ x" by auto
from content_primitive_part[OF f0] have cp: "content pp = 1" unfolding pp_def .
let ?p' = "pderiv pp"
{
assume "resultant pp ?p' = 0"
from this[unfolded resultant_0_gcd] have "¬ coprime pp ?p'" by auto
then obtain r where r: "r dvd pp" "r dvd ?p'" "¬ r dvd 1"
by (blast elim: not_coprimeE)
from r(1) obtain k where "pp = r * k" ..
from pos_zmult_eq_1_iff_lemma[OF arg_cong[OF this,
of content, unfolded content_mult cp, symmetric]] content_ge_0_int[of r]
have cr: "content r = 1" by auto
with r(3) content_free_unit have dr: "degree r ≠ 0" by auto
let ?r = "map_poly rat_of_int"
from r(1) have dvd: "?r r dvd ?r pp" unfolding dvd_def by (auto simp: hom_distribs)
from r(2) have "?r r dvd ?r ?p'" apply (intro of_int_poly_hom.hom_dvd) by auto
also have "?r ?p' = pderiv (?r pp)" unfolding of_int_hom.map_poly_pderiv ..
finally have dvd': "?r r dvd pderiv (?r pp)" by auto
from dr have dr': "degree (?r r) ≠ 0" by simp
from square_free_imp_separable[OF square_free_int_rat[OF sf']]
have "separable (?r pp)" .
hence cop: "coprime (?r pp) (pderiv (?r pp))" unfolding separable_def .
from f0 f have pp0: "pp ≠ 0" by auto
from dvd dvd' have "?r r dvd gcd (?r pp) (pderiv (?r pp))" by auto
from divides_degree[OF this] pp0 have "degree (?r r) ≤ degree (gcd (?r pp) (pderiv (?r pp)))"
by auto
with dr' have "degree (gcd (?r pp) (pderiv (?r pp))) ≠ 0" by auto
hence "¬ coprime (?r pp) (pderiv (?r pp))" by auto
with cop have False by auto
}
hence "resultant pp ?p' ≠ 0" by auto
with resultant_smult_left[OF c0, of pp ?p', folded f] c0
have "resultant f ?p' ≠ 0" by auto
with resultant_smult_right[OF c0, of f ?p', folded pderiv_smult f] c0
show "resultant f (pderiv f) ≠ 0" by auto
qed
lemma large_mod_0: assumes "(n :: int) > 1" "¦k¦ < n" "k mod n = 0" shows "k = 0"
proof -
from ‹k mod n = 0› have "n dvd k"
by auto
then obtain m where "k = n * m" ..
with ‹n > 1› ‹¦k¦ < n› show ?thesis
by (auto simp add: abs_mult)
qed
definition separable_bound :: "int poly ⇒ int" where
"separable_bound f = max (abs (resultant f (pderiv f)))
(max (abs (lead_coeff f)) (abs (lead_coeff (pderiv f))))"
lemma square_free_int_imp_resultant_non_zero_mod_ring: assumes sf: "square_free f"
and large: "int CARD('a) > separable_bound f"
shows "resultant (map_poly of_int f :: 'a :: prime_card mod_ring poly) (pderiv (map_poly of_int f)) ≠ 0
∧ map_poly of_int f ≠ (0 :: 'a mod_ring poly)"
proof (intro conjI, rule notI)
let ?i = "of_int :: int ⇒ 'a mod_ring"
let ?m = "of_int_poly :: _ ⇒ 'a mod_ring poly"
let ?f = "?m f"
from sf[unfolded square_free_def] have f0: "f ≠ 0" by auto
hence lf: "lead_coeff f ≠ 0" by auto
{
fix k :: int
have C1: "int CARD('a) > 1" using prime_card[where 'a = 'a] by (auto simp: prime_nat_iff)
assume "abs k < CARD('a)" and "?i k = 0"
hence "k = 0" unfolding of_int_of_int_mod_ring
by (transfer) (rule large_mod_0[OF C1])
} note of_int_0 = this
from square_free_imp_resultant_non_zero[OF sf]
have non0: "resultant f (pderiv f) ≠ 0" .
{
fix g :: "int poly"
assume abs: "abs (lead_coeff g) < CARD('a)"
have "degree (?m g) = degree g" by (rule degree_map_poly, insert of_int_0[OF abs], auto)
} note deg = this
note large = large[unfolded separable_bound_def]
from of_int_0[of "lead_coeff f"] large lf have "?i (lead_coeff f) ≠ 0" by auto
thus f0: "?f ≠ 0" unfolding poly_eq_iff by auto
assume 0: "resultant ?f (pderiv ?f) = 0"
have "resultant ?f (pderiv ?f) = ?i (resultant f (pderiv f))"
unfolding of_int_hom.map_poly_pderiv[symmetric]
by (subst of_int_hom.resultant_map_poly(1)[OF deg deg], insert large, auto simp: hom_distribs)
from of_int_0[OF _ this[symmetric, unfolded 0]] non0
show False using large by auto
qed
lemma square_free_int_imp_separable_mod_ring: assumes sf: "square_free f"
and large: "int CARD('a) > separable_bound f"
shows "separable (map_poly of_int f :: 'a :: prime_card mod_ring poly)"
proof -
define g where "g = map_poly (of_int :: int ⇒ 'a mod_ring) f"
from square_free_int_imp_resultant_non_zero_mod_ring[OF sf large]
have res: "resultant g (pderiv g) ≠ 0" and g: "g ≠ 0" unfolding g_def by auto
from res[unfolded resultant_0_gcd] have "degree (gcd g (pderiv g)) = 0" by auto
from degree0_coeffs[OF this]
have "separable g" unfolding separable_def
by (metis degree_pCons_0 g gcd_eq_0_iff is_unit_gcd is_unit_iff_degree)
thus ?thesis unfolding g_def .
qed
lemma square_free_int_imp_square_free_mod_ring: assumes sf: "square_free f"
and large: "int CARD('a) > separable_bound f"
shows "square_free (map_poly of_int f :: 'a :: prime_card mod_ring poly)"
using separable_imp_square_free[OF square_free_int_imp_separable_mod_ring[OF assms]] .
end
Theory Suitable_Prime
subsection ‹Finding a Suitable Prime›
text ‹The Berlekamp-Zassenhaus algorithm demands for an input polynomial $f$ to determine
a prime $p$ such that $f$ is square-free mod $p$ and such that $p$ and the leading coefficient
of $f$ are coprime. To this end, we first prove that such a prime always exists, provided that
$f$ is square-free over the integers. Second, we provide a generic algorithm which searches for
primes have a certain property $P$. Combining both results gives us the suitable prime for
the Berlekamp-Zassenhaus algorithm.›
theory Suitable_Prime
imports
Poly_Mod
Finite_Field_Record_Based
"HOL-Types_To_Sets.Types_To_Sets"
Poly_Mod_Finite_Field_Record_Based
Polynomial_Record_Based
Square_Free_Int_To_Square_Free_GFp
begin
lemma square_free_separable_GFp: fixes f :: "'a :: prime_card mod_ring poly"
assumes card: "CARD('a) > degree f"
and sf: "square_free f"
shows "separable f"
proof (rule ccontr)
assume "¬ separable f"
with square_free_separable_main[OF sf]
obtain g k where *: "f = g * k" "degree g ≠ 0" and g0: "pderiv g = 0" by auto
from assms have f: "f ≠ 0" unfolding square_free_def by auto
have "degree f = degree g + degree k" using f unfolding *(1)
by (subst degree_mult_eq, auto)
with card have card: "degree g < CARD('a)" by auto
from *(2) obtain n where deg: "degree g = Suc n" by (cases "degree g", auto)
from *(2) have cg: "coeff g (degree g) ≠ 0" by auto
from g0 have "coeff (pderiv g) n = 0" by auto
from this[unfolded coeff_pderiv, folded deg] cg
have "of_nat (degree g) = (0 :: 'a mod_ring)" by auto
from of_nat_0_mod_ring_dvd[OF this] have "CARD('a) dvd degree g" .
with card show False by (simp add: deg nat_dvd_not_less)
qed
lemma square_free_iff_separable_GFp: assumes "degree f < CARD('a)"
shows "square_free (f :: 'a :: prime_card mod_ring poly) = separable f"
using separable_imp_square_free[of f] square_free_separable_GFp[OF assms] by auto
definition separable_impl_main :: "int ⇒ 'i arith_ops_record ⇒ int poly ⇒ bool" where
"separable_impl_main p ff_ops f = separable_i ff_ops (of_int_poly_i ff_ops (poly_mod.Mp p f))"
lemma (in prime_field_gen) separable_impl:
shows "separable_impl_main p ff_ops f ⟹ square_free_m f"
"p > degree_m f ⟹ p > separable_bound f ⟹ square_free f
⟹ separable_impl_main p ff_ops f" unfolding separable_impl_main_def
proof -
define F where F: "(F :: 'a mod_ring poly) = of_int_poly (Mp f)"
let ?f' = "of_int_poly_i ff_ops (Mp f)"
define f'' where "f'' ≡ of_int_poly (Mp f) :: 'a mod_ring poly"
have rel_f[transfer_rule]: "poly_rel ?f' f''"
by (rule poly_rel_of_int_poly[OF refl], simp add: f''_def)
have "separable_i ff_ops ?f' ⟷ gcd f'' (pderiv f'') = 1"
unfolding separable_i_def by transfer_prover
also have "… ⟷ coprime f'' (pderiv f'')"
by (auto simp add: gcd_eq_1_imp_coprime)
finally have id: "separable_i ff_ops ?f' ⟷ separable f''" unfolding separable_def coprime_iff_coprime .
have Mprel [transfer_rule]: "MP_Rel (Mp f) F" unfolding F MP_Rel_def
by (simp add: Mp_f_representative)
have "square_free f'' = square_free F" unfolding f''_def F by simp
also have "… = square_free_m (Mp f)"
by (transfer, simp)
also have "… = square_free_m f" by simp
finally have id2: "square_free f'' = square_free_m f" .
from separable_imp_square_free[of f'']
show "separable_i ff_ops ?f' ⟹ square_free_m f"
unfolding id id2 by auto
let ?m = "map_poly (of_int :: int ⇒ 'a mod_ring)"
let ?f = "?m f"
assume "p > degree_m f" and bnd: "p > separable_bound f" and sf: "square_free f"
with rel_funD[OF degree_MP_Rel Mprel, folded p]
have "p > degree F" by simp
hence "CARD('a) > degree f''" unfolding f''_def F p by simp
from square_free_iff_separable_GFp[OF this]
have "separable_i ff_ops ?f' = square_free f''" unfolding id id2 by simp
also have "… = square_free F" unfolding f''_def F by simp
also have "F = ?f" unfolding F
by (rule poly_eqI, (subst coeff_map_poly, force)+, unfold Mp_coeff,
auto simp: M_def, transfer, auto simp: p)
also have "square_free ?f" using square_free_int_imp_square_free_mod_ring[where 'a = 'a, OF sf] bnd m by auto
finally
show "separable_i ff_ops ?f'" .
qed
context poly_mod_prime begin
lemmas separable_impl_integer = prime_field_gen.separable_impl
[OF prime_field.prime_field_finite_field_ops_integer, unfolded prime_field_def mod_ring_locale_def,
unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise,cancel_type_definition, OF non_empty]
lemmas separable_impl_uint32 = prime_field_gen.separable_impl
[OF prime_field.prime_field_finite_field_ops32, unfolded prime_field_def mod_ring_locale_def,
unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise,cancel_type_definition, OF non_empty]
lemmas separable_impl_uint64 = prime_field_gen.separable_impl
[OF prime_field.prime_field_finite_field_ops64, unfolded prime_field_def mod_ring_locale_def,
unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise,cancel_type_definition, OF non_empty]
end
definition separable_impl :: "int ⇒ int poly ⇒ bool" where
"separable_impl p = (
if p ≤ 65535
then separable_impl_main p (finite_field_ops32 (uint32_of_int p))
else if p ≤ 4294967295
then separable_impl_main p (finite_field_ops64 (uint64_of_int p))
else separable_impl_main p (finite_field_ops_integer (integer_of_int p)))"
lemma square_free_mod_imp_square_free: assumes
p: "prime p" and sf: "poly_mod.square_free_m p f"
and cop: "coprime (lead_coeff f) p"
shows "square_free f"
proof -
interpret poly_mod p .
from sf[unfolded square_free_m_def] have f0: "Mp f ≠ 0" and ndvd: "⋀ g. degree_m g > 0 ⟹ ¬ (g * g) dvdm f"
by auto
from f0 have ff0: "f ≠ 0" by auto
show "square_free f" unfolding square_free_def
proof (intro conjI[OF ff0] allI impI notI)
fix g
assume deg: "degree g > 0" and dvd: "g * g dvd f"
then obtain h where f: "f = g * g * h" unfolding dvd_def by auto
from arg_cong[OF this, of Mp] have "(g * g) dvdm f" unfolding dvdm_def by auto
with ndvd[of g] have deg0: "degree_m g = 0" by auto
hence g0: "M (lead_coeff g) = 0" unfolding Mp_def using deg
by (metis M_def deg0 p poly_mod.degree_m_eq prime_gt_1_int neq0_conv)
from p have p0: "p ≠ 0" by auto
from arg_cong[OF f, of lead_coeff] have "lead_coeff f = lead_coeff g * lead_coeff g * lead_coeff h"
by (auto simp: lead_coeff_mult)
hence "lead_coeff g dvd lead_coeff f" by auto
with cop have cop: "coprime (lead_coeff g) p"
by (auto elim: coprime_imp_coprime intro: dvd_trans)
with p0 have "coprime (lead_coeff g mod p) p" by simp
also have "lead_coeff g mod p = 0"
using M_def g0 by simp
finally show False using p
unfolding prime_int_iff
by (simp add: prime_int_iff)
qed
qed
lemma(in poly_mod_prime) separable_impl:
shows "separable_impl p f ⟹ square_free_m f"
"nat p > degree_m f ⟹ nat p > separable_bound f ⟹ square_free f
⟹ separable_impl p f"
using
separable_impl_integer[of f]
separable_impl_uint32[of f]
separable_impl_uint64[of f]
unfolding separable_impl_def by (auto split: if_splits)
lemma coprime_lead_coeff_large_prime: assumes prime: "prime (p :: int)"
and large: "p > abs (lead_coeff f)"
and f: "f ≠ 0"
shows "coprime (lead_coeff f) p"
proof -
{
fix lc
assume "0 < lc" "lc < p"
then have "¬ p dvd lc"
by (simp add: zdvd_not_zless)
with ‹prime p› have "coprime p lc"
by (auto intro: prime_imp_coprime)
then have "coprime lc p"
by (simp add: ac_simps)
} note main = this
define lc where "lc = lead_coeff f"
from f have lc0: "lc ≠ 0" unfolding lc_def by auto
from large have large: "p > abs lc" unfolding lc_def by auto
have "coprime lc p"
proof (cases "lc > 0")
case True
from large have "p > lc" by auto
from main[OF True this] show ?thesis .
next
case False
let ?mlc = "- lc"
from large False lc0 have "?mlc > 0" "p > ?mlc" by auto
from main[OF this] show ?thesis by simp
qed
thus ?thesis unfolding lc_def by auto
qed
lemma prime_for_berlekamp_zassenhaus_exists: assumes sf: "square_free f"
shows "∃ p. prime p ∧ (coprime (lead_coeff f) p ∧ separable_impl p f)"
proof (rule ccontr)
from assms have f0: "f ≠ 0" unfolding square_free_def by auto
define n where "n = max (max (abs (lead_coeff f)) (degree f)) (separable_bound f)"
assume contr: "¬ ?thesis"
{
fix p :: int
assume prime: "prime p" and n: "p > n"
then interpret poly_mod_prime p by unfold_locales
from n have large: "p > abs (lead_coeff f)" "nat p > degree f" "nat p > separable_bound f"
unfolding n_def by auto
from coprime_lead_coeff_large_prime[OF prime large(1) f0]
have cop: "coprime (lead_coeff f) p" by auto
with prime contr have nsf: "¬ separable_impl p f" by auto
from large(2) have "nat p > degree_m f" using degree_m_le[of f] by auto
from separable_impl(2)[OF this large(3) sf] nsf have False by auto
}
hence no_large_prime: "⋀ p. prime p ⟹ p > n ⟹ False" by auto
from bigger_prime[of "nat n"] obtain p where *: "prime p" "p > nat n" by auto
define q where "q ≡ int p"
from * have "prime q" "q > n" unfolding q_def by auto
from no_large_prime[OF this]
show False .
qed
definition next_primes :: "nat ⇒ nat × nat list" where
"next_primes n = (if n = 0 then next_candidates 0 else
let (m,ps) = next_candidates n in (m,filter prime ps))"
partial_function (tailrec) find_prime_main ::
"(nat ⇒ bool) ⇒ nat ⇒ nat list ⇒ nat" where
[code]: "find_prime_main f np ps = (case ps of [] ⇒
let (np',ps') = next_primes np
in find_prime_main f np' ps'
| (p # ps) ⇒ if f p then p else find_prime_main f np ps)"
definition find_prime :: "(nat ⇒ bool) ⇒ nat" where
"find_prime f = find_prime_main f 0 []"
lemma next_primes: assumes res: "next_primes n = (m,ps)"
and n: "candidate_invariant n"
shows "candidate_invariant m" "sorted ps" "distinct ps" "n < m"
"set ps = {i. prime i ∧ n ≤ i ∧ i < m}"
proof -
have "candidate_invariant m ∧ sorted ps ∧ distinct ps ∧ n < m ∧
set ps = {i. prime i ∧ n ≤ i ∧ i < m}"
proof (cases "n = 0")
case True
with res[unfolded next_primes_def] have nc: "next_candidates 0 = (m,ps)" by auto
from this[unfolded next_candidates_def] have ps: "ps = primes_1000" and m: "m = 1001" by auto
have ps: "set ps = {i. prime i ∧ n ≤ i ∧ i < m}" unfolding m True ps
by (auto simp: primes_1000)
with next_candidates[OF nc n[unfolded True]] True
show ?thesis by simp
next
case False
with res[unfolded next_primes_def Let_def] obtain qs where nc: "next_candidates n = (m, qs)"
and ps: "ps = filter prime qs" by (cases "next_candidates n", auto)
have "sorted qs ⟹ sorted ps" unfolding ps using sorted_filter[of id qs prime] by auto
with next_candidates[OF nc n] show ?thesis unfolding ps by auto
qed
thus "candidate_invariant m" "sorted ps" "distinct ps" "n < m"
"set ps = {i. prime i ∧ n ≤ i ∧ i < m}" by auto
qed
lemma find_prime: assumes "∃ n. prime n ∧ f n"
shows "prime (find_prime f) ∧ f (find_prime f)"
proof -
from assms obtain n where fn: "prime n" "f n" by auto
{
fix i ps m
assume "candidate_invariant i"
and "n ∈ set ps ∨ n ≥ i"
and "m = (Suc n - i, length ps)"
and "⋀ p. p ∈ set ps ⟹ prime p"
hence "prime (find_prime_main f i ps) ∧ f (find_prime_main f i ps)"
proof (induct m arbitrary: i ps rule: wf_induct[OF wf_measures[of "[fst, snd]"]])
case (1 m i ps)
note IH = 1(1)[rule_format]
note can = 1(2)
note n = 1(3)
note m = 1(4)
note ps = 1(5)
note simps [simp] = find_prime_main.simps[of f i ps]
show ?case
proof (cases ps)
case Nil
with n have i_n: "i ≤ n" by auto
obtain j qs where np: "next_primes i = (j,qs)" by force
note j = next_primes[OF np can]
from j(4) i_n m have meas: "((Suc n - j, length qs), m) ∈ measures [fst, snd]" by auto
have n: "n ∈ set qs ∨ j ≤ n" unfolding j(5) using i_n fn by auto
show ?thesis unfolding simps using IH[OF meas j(1) n refl] j(5) by (simp add: Nil np)
next
case (Cons p qs)
show ?thesis
proof (cases "f p")
case True
thus ?thesis unfolding simps using ps unfolding Cons by simp
next
case False
have m: "((Suc n - i, length qs), m) ∈ measures [fst, snd]" using m unfolding Cons by simp
have n: "n ∈ set qs ∨ i ≤ n" using False n fn by (auto simp: Cons)
from IH[OF m can n refl ps]
show ?thesis unfolding simps using Cons False by simp
qed
qed
qed
} note main = this
have "candidate_invariant 0" by (simp add: candidate_invariant_def)
from main[OF this _ refl, of Nil] show ?thesis unfolding find_prime_def by auto
qed
definition suitable_prime_bz :: "int poly ⇒ int" where
"suitable_prime_bz f ≡ let lc = lead_coeff f in int (find_prime (λ n. let p = int n in
coprime lc p ∧ separable_impl p f))"
lemma suitable_prime_bz: assumes sf: "square_free f" and p: "p = suitable_prime_bz f"
shows "prime p" "coprime (lead_coeff f) p" "poly_mod.square_free_m p f"
proof -
let ?lc = "lead_coeff f"
from prime_for_berlekamp_zassenhaus_exists[OF sf, unfolded Let_def]
obtain P where *: "prime P ∧ coprime ?lc P ∧ separable_impl P f"
by auto
hence "prime (nat P)" using prime_int_nat_transfer by blast
with * have "∃ p. prime p ∧ coprime ?lc (int p) ∧ separable_impl p f"
by (intro exI [of _ "nat P"]) (auto dest: prime_gt_0_int)
from find_prime[OF this]
have prime: "prime p" and cop: "coprime ?lc p" and sf: "separable_impl p f"
unfolding p suitable_prime_bz_def Let_def by auto
then interpret poly_mod_prime p by unfold_locales
from prime cop separable_impl(1)[OF sf]
show "prime p" "coprime ?lc p" "square_free_m f" by auto
qed
definition square_free_heuristic :: "int poly ⇒ int option" where
"square_free_heuristic f = (let lc = lead_coeff f in
find (λ p. coprime lc p ∧ separable_impl p f) [2, 3, 5, 7, 11, 13, 17, 19, 23])"
lemma find_Some_D: "find f xs = Some y ⟹ y ∈ set xs ∧ f y" unfolding find_Some_iff by auto
lemma square_free_heuristic: assumes "square_free_heuristic f = Some p"
shows "coprime (lead_coeff f) p ∧ separable_impl p f ∧ prime p"
proof -
from find_Some_D[OF assms[unfolded square_free_heuristic_def Let_def]]
show ?thesis by auto
qed
end
Theory Degree_Bound
subsection ‹Maximal Degree during Reconstruction›
text ‹We define a function which computes an upper bound on the degree of
a factor for which we have to reconstruct the integer values of the coefficients.
This degree will determine how large the second parameter of the factor-bound will
be.
In essence, if the Berlekamp-factorization will produce $n$ factors with degrees
$d_1,\ldots,d_n$, then our bound will be the sum of the $\frac{n}2$ largest degrees.
The reason is that we will combine at most $\frac{n}2$ factors before reconstruction.
Soundness of the bound is proven, as well as a monotonicity property.›
theory Degree_Bound
imports Containers.Set_Impl
"HOL-Library.Multiset"
Polynomial_Interpolation.Missing_Polynomial
"Efficient-Mergesort.Efficient_Sort"
begin
definition max_factor_degree :: "nat list ⇒ nat" where
"max_factor_degree degs = (let
ds = sort degs
in sum_list (drop (length ds div 2) ds))"
definition degree_bound where "degree_bound vs = max_factor_degree (map degree vs)"
lemma insort_middle: "sort (xs @ x # ys) = insort x (sort (xs @ ys))"
by (metis append.assoc sort_append_Cons_swap sort_snoc)
lemma sum_list_insort[simp]:
"sum_list (insort (d :: 'a :: {comm_monoid_add,linorder}) xs) = d + sum_list xs"
proof (induct xs)
case (Cons x xs)
thus ?case by (cases "d ≤ x", auto simp: ac_simps)
qed simp
lemma half_largest_elements_mono: "sum_list (drop (length ds div 2) (sort ds))
≤ sum_list (drop (Suc (length ds) div 2) (insort (d :: nat) (sort ds)))"
proof -
define n where "n = length ds div 2"
define m where "m = Suc (length ds) div 2"
define xs where "xs = sort ds"
have xs: "sorted xs" unfolding xs_def by auto
have nm: "m ∈ {n, Suc n}" unfolding n_def m_def by auto
show ?thesis unfolding n_def[symmetric] m_def[symmetric] xs_def[symmetric]
using nm xs
proof (induct xs arbitrary: n m d)
case (Cons x xs n m d)
show ?case
proof (cases n)
case 0
with Cons(2) have m: "m = 0 ∨ m = 1" by auto
show ?thesis
proof (cases "d ≤ x")
case True
hence ins: "insort d (x # xs) = d # x # xs" by auto
show ?thesis unfolding ins 0 using True m by auto
next
case False
hence ins: "insort d (x # xs) = x # insort d xs" by auto
show ?thesis unfolding ins 0 using False m by auto
qed
next
case (Suc nn)
with Cons(2) obtain mm where m: "m = Suc mm" and mm: "mm ∈ {nn, Suc nn}" by auto
from Cons(3) have sort: "sorted xs" by (simp)
note IH = Cons(1)[OF mm]
show ?thesis
proof (cases "d ≤ x")
case True
with Cons(3) have ins: "insort d (x # xs) = d # insort x xs"
by (cases xs, auto)
show ?thesis unfolding ins Suc m using IH[OF sort] by auto
next
case False
hence ins: "insort d (x # xs) = x # insort d xs" by auto
show ?thesis unfolding ins Suc m using IH[OF sort] Cons(3) by auto
qed
qed
qed auto
qed
lemma max_factor_degree_mono:
"max_factor_degree (map degree (fold remove1 ws vs)) ≤ max_factor_degree (map degree vs)"
unfolding max_factor_degree_def Let_def length_sort length_map
proof (induct ws arbitrary: vs)
case (Cons w ws vs)
show ?case
proof (cases "w ∈ set vs")
case False
hence "remove1 w vs = vs" by (rule remove1_idem)
thus ?thesis using Cons[of vs] by auto
next
case True
then obtain bef aft where vs: "vs = bef @ w # aft" and rem1: "remove1 w vs = bef @ aft"
by (metis remove1.simps(2) remove1_append split_list_first)
let ?exp = "λ ws vs. sum_list (drop (length (fold remove1 ws vs) div 2)
(sort (map degree (fold remove1 ws vs))))"
let ?bnd = "λ vs. sum_list (drop (length vs div 2) (sort (map degree vs)))"
let ?bd = "λ vs. sum_list (drop (length vs div 2) (sort vs))"
define ba where "ba = bef @ aft"
define ds where "ds = map degree ba"
define d where "d = degree w"
have "?exp (w # ws) vs = ?exp ws (bef @ aft)" by (auto simp: rem1)
also have "… ≤ ?bnd ba" unfolding ba_def by (rule Cons)
also have "… = ?bd ds" unfolding ds_def by simp
also have "… ≤ sum_list (drop (Suc (length ds) div 2) (insort d (sort ds)))"
by (rule half_largest_elements_mono)
also have "… = ?bnd vs" unfolding vs ds_def d_def by (simp add: ba_def insort_middle)
finally show "?exp (w # ws) vs ≤ ?bnd vs" by simp
qed
qed auto
lemma mset_sub_decompose: "mset ds ⊆# mset bs + as ⟹ length ds < length bs ⟹ ∃ b1 b b2.
bs = b1 @ b # b2 ∧ mset ds ⊆# mset (b1 @ b2) + as"
proof (induct ds arbitrary: bs as)
case Nil
hence "bs = [] @ hd bs # tl bs" by auto
thus ?case by fastforce
next
case (Cons d ds bs as)
have "d ∈# mset (d # ds)" by auto
with Cons(2) have d: "d ∈# mset bs + as" by (rule mset_subset_eqD)
hence "d ∈ set bs ∨ d ∈# as" by auto
thus ?case
proof
assume "d ∈ set bs"
from this[unfolded in_set_conv_decomp] obtain b1 b2 where bs: "bs = b1 @ d # b2" by auto
from Cons(2) Cons(3)
have "mset ds ⊆# mset (b1 @ b2) + as" "length ds < length (b1 @ b2)" by (auto simp: ac_simps bs)
from Cons(1)[OF this] obtain b1' b b2' where split: "b1 @ b2 = b1' @ b # b2'"
and sub: "mset ds ⊆# mset (b1' @ b2') + as" by auto
from split[unfolded append_eq_append_conv2]
obtain us where "b1 = b1' @ us ∧ us @ b2 = b # b2' ∨ b1 @ us = b1' ∧ b2 = us @ b # b2'" ..
thus ?thesis
proof
assume "b1 @ us = b1' ∧ b2 = us @ b # b2'"
hence *: "b1 @ us = b1'" "b2 = us @ b # b2'" by auto
hence bs: "bs = (b1 @ d # us) @ b # b2'" unfolding bs by auto
show ?thesis
by (intro exI conjI, rule bs, insert * sub, auto simp: ac_simps)
next
assume "b1 = b1' @ us ∧ us @ b2 = b # b2'"
hence *: "b1 = b1' @ us" "us @ b2 = b # b2'" by auto
show ?thesis
proof (cases us)
case Nil
with * have *: "b1 = b1'" "b2 = b # b2'" by auto
hence bs: "bs = (b1' @ [d]) @ b # b2'" unfolding bs by simp
show ?thesis
by (intro exI conjI, rule bs, insert * sub, auto simp: ac_simps)
next
case (Cons u vs)
with * have *: "b1 = b1' @ b # vs" "vs @ b2 = b2'" by auto
hence bs: "bs = b1' @ b # (vs @ d # b2)" unfolding bs by auto
show ?thesis
by (intro exI conjI, rule bs, insert * sub, auto simp: ac_simps)
qed
qed
next
define as' where "as' = as - {#d#}"
assume "d ∈# as"
hence as': "as = {#d#} + as'" unfolding as'_def by auto
from Cons(2)[unfolded as'] Cons(3) have "mset ds ⊆# mset bs + as'" "length ds < length bs"
by (auto simp: ac_simps)
from Cons(1)[OF this] obtain b1 b b2 where bs: "bs = b1 @ b # b2" and
sub: "mset ds ⊆# mset (b1 @ b2) + as'" by auto
show ?thesis
by (intro exI conjI, rule bs, insert sub, auto simp: as' ac_simps)
qed
qed
lemma max_factor_degree_aux: fixes es :: "nat list"
assumes sub: "mset ds ⊆# mset es"
and len: "length ds + length ds ≤ length es" and sort: "sorted es"
shows "sum_list ds ≤ sum_list (drop (length es div 2) es)"
proof -
define bef where "bef = take (length es div 2) es"
define aft where "aft = drop (length es div 2) es"
have es: "es = bef @ aft" unfolding bef_def aft_def by auto
from len have len: "length ds ≤ length bef" "length ds ≤ length aft" unfolding bef_def aft_def
by auto
from sub have sub: "mset ds ⊆# mset bef + mset aft" unfolding es by auto
from sort have sort: "sorted (bef @ aft)" unfolding es .
show ?thesis unfolding aft_def[symmetric] using sub len sort
proof (induct ds arbitrary: bef aft)
case (Cons d ds bef aft)
have "d ∈# mset (d # ds)" by auto
with Cons(2) have "d ∈# mset bef + mset aft" by (rule mset_subset_eqD)
hence "d ∈ set bef ∨ d ∈ set aft" by auto
thus ?case
proof
assume "d ∈ set aft"
from this[unfolded in_set_conv_decomp] obtain a1 a2 where aft: "aft = a1 @ d # a2" by auto
from Cons(4) have len_a: "length ds ≤ length (a1 @ a2)" unfolding aft by auto
from Cons(2)[unfolded aft] Cons(3)
have "mset ds ⊆# mset bef + (mset (a1 @ a2))" "length ds < length bef" by auto
from mset_sub_decompose[OF this]
obtain b b1 b2
where bef: "bef = b1 @ b # b2" and sub: "mset ds ⊆# (mset (b1 @ b2) + mset (a1 @ a2))" by auto
from Cons(3) have len_b: "length ds ≤ length (b1 @ b2)" unfolding bef by auto
from Cons(5)[unfolded bef aft] have sort: "sorted ( (b1 @ b2) @ (a1 @ a2))"
unfolding sorted_append by auto
note IH = Cons(1)[OF sub len_b len_a sort]
show ?thesis using IH unfolding aft by simp
next
assume "d ∈ set bef"
from this[unfolded in_set_conv_decomp] obtain b1 b2 where bef: "bef = b1 @ d # b2" by auto
from Cons(3) have len_b: "length ds ≤ length (b1 @ b2)" unfolding bef by auto
from Cons(2)[unfolded bef] Cons(4)
have "mset ds ⊆# mset aft + (mset (b1 @ b2))" "length ds < length aft" by (auto simp: ac_simps)
from mset_sub_decompose[OF this]
obtain a a1 a2
where aft: "aft = a1 @ a # a2" and sub: "mset ds ⊆# (mset (b1 @ b2) + mset (a1 @ a2))"
by (auto simp: ac_simps)
from Cons(4) have len_a: "length ds ≤ length (a1 @ a2)" unfolding aft by auto
from Cons(5)[unfolded bef aft] have sort: "sorted ( (b1 @ b2) @ (a1 @ a2))" and ad: "d ≤ a"
unfolding sorted_append by auto
note IH = Cons(1)[OF sub len_b len_a sort]
show ?thesis using IH ad unfolding aft by simp
qed
qed auto
qed
lemma max_factor_degree: assumes sub: "mset ws ⊆# mset vs"
and len: "length ws + length ws ≤ length vs"
shows "degree (prod_list ws) ≤ max_factor_degree (map degree vs)"
proof -
define ds where "ds ≡ map degree ws"
define es where "es ≡ sort (map degree vs)"
from sub len have sub: "mset ds ⊆# mset es" and len: "length ds + length ds ≤ length es"
and es: "sorted es"
unfolding ds_def es_def
by (auto simp: image_mset_subseteq_mono)
have "degree (prod_list ws) ≤ sum_list (map degree ws)" by (rule degree_prod_list_le)
also have "… ≤ max_factor_degree (map degree vs)"
unfolding max_factor_degree_def Let_def ds_def[symmetric] es_def[symmetric]
using sub len es by (rule max_factor_degree_aux)
finally show ?thesis .
qed
lemma degree_bound: assumes sub: "mset ws ⊆# mset vs"
and len: "length ws + length ws ≤ length vs"
shows "degree (prod_list ws) ≤ degree_bound vs"
using max_factor_degree[OF sub len] unfolding degree_bound_def by auto
end
Theory Mahler_Measure
subsection ‹Mahler Measure›
text ‹This part contains a definition of the Mahler measure, it contains Landau's inequality and
the Graeffe-transformation. We also assemble a heuristic to approximate the Mahler's measure.›
theory Mahler_Measure
imports
Sqrt_Babylonian.Sqrt_Babylonian
Poly_Mod_Finite_Field_Record_Based
Polynomial_Factorization.Fundamental_Theorem_Algebra_Factorized
Polynomial_Factorization.Missing_Multiset
begin
context comm_monoid_list begin
lemma induct_gen_abs:
assumes "⋀ a r. a∈set lst ⟹ P (f (h a) r) (f (g a) r)"
"⋀ x y z. P x y ⟹ P y z ⟹ P x z"
"P (F (map g lst)) (F (map g lst))"
shows "P (F (map h lst)) (F (map g lst)) "
using assms proof(induct lst arbitrary:P)
case (Cons a as P)
have inl:"a∈set (a#as)" by auto
let ?uf = "λ v w. P (f (g a) v) (f (g a) w)"
have p_suc:"?uf (F (map g as)) (F (map g as))"
using Cons.prems(3) by auto
{ fix r aa assume "aa ∈ set as" hence ins:"aa ∈ set (a#as)" by auto
have "P (f (g a) (f (h aa) r)) (f (g a) (f (g aa) r))"
using Cons.prems(1)[of aa "f r (g a)",OF ins]
by (auto simp: assoc commute left_commute)
} note h = this
from Cons.hyps(1)[of ?uf, OF h Cons.prems(2)[simplified] p_suc]
have e1:"P (f (g a) (F (map h as))) (f (g a) (F (map g as)))" by simp
have e2:"P (f (h a) (F (map h as))) (f (g a) (F (map h as)))"
using Cons.prems(1)[OF inl] by blast
from Cons(3)[OF e2 e1] show ?case by auto next
qed auto
end
lemma prod_induct_gen:
assumes "⋀ a r. f (h a * r :: 'a :: {comm_monoid_mult}) = f (g a * r)"
shows "f (∏v←lst. h v) = f (∏v←lst. g v)"
proof - let "?P x y" = "f x = f y"
show ?thesis using comm_monoid_mult_class.prod_list.induct_gen_abs[of _ ?P,OF assms] by auto
qed
abbreviation complex_of_int::"int ⇒ complex" where
"complex_of_int ≡ of_int"
definition l2norm_list :: "int list ⇒ int" where
"l2norm_list lst = ⌊sqrt (sum_list (map (λ a. a * a) lst))⌋"
abbreviation l2norm :: "int poly ⇒ int" where
"l2norm p ≡ l2norm_list (coeffs p)"
abbreviation "norm2 p ≡ ∑a←coeffs p. (cmod a)⇧2"
abbreviation l2norm_complex where
"l2norm_complex p ≡ sqrt (norm2 p)"
abbreviation height :: "int poly ⇒ int" where
"height p ≡ max_list (map (nat ∘ abs) (coeffs p))"
definition complex_roots_complex where
"complex_roots_complex (p::complex poly) = (SOME as. smult (coeff p (degree p)) (∏a←as. [:- a, 1:]) = p ∧ length as = degree p)"
lemma complex_roots:
"smult (lead_coeff p) (∏a←complex_roots_complex p. [:- a, 1:]) = p"
"length (complex_roots_complex p) = degree p"
using someI_ex[OF fundamental_theorem_algebra_factorized]
unfolding complex_roots_complex_def by simp_all
lemma complex_roots_c [simp]:
"complex_roots_complex [:c:] = []"
using complex_roots(2) [of "[:c:]"] by simp
declare complex_roots(2)[simp]
lemma complex_roots_1 [simp]:
"complex_roots_complex 1 = []"
using complex_roots_c [of 1] by (simp add: pCons_one)
lemma linear_term_irreducible⇩d[simp]: "irreducible⇩d [: a, 1:]"
by (rule linear_irreducible⇩d, simp)
definition complex_roots_int where
"complex_roots_int (p::int poly) = complex_roots_complex (map_poly of_int p)"
lemma complex_roots_int:
"smult (lead_coeff p) (∏a←complex_roots_int p. [:- a, 1:]) = map_poly of_int p"
"length (complex_roots_int p) = degree p"
proof -
show "smult (lead_coeff p) (∏a←complex_roots_int p. [:- a, 1:]) = map_poly of_int p"
"length (complex_roots_int p) = degree p"
using complex_roots[of "map_poly of_int p"] unfolding complex_roots_int_def by auto
qed
text ‹The measure for polynomials, after K. Mahler›
definition mahler_measure_poly where
"mahler_measure_poly p = cmod (lead_coeff p) * (∏a←complex_roots_complex p. (max 1 (cmod a)))"
definition mahler_measure where
"mahler_measure p = mahler_measure_poly (map_poly complex_of_int p)"
definition mahler_measure_monic where
"mahler_measure_monic p = (∏a←complex_roots_complex p. (max 1 (cmod a)))"
lemma mahler_measure_poly_via_monic :
"mahler_measure_poly p = cmod (lead_coeff p) * mahler_measure_monic p"
unfolding mahler_measure_poly_def mahler_measure_monic_def by simp
lemma smult_inj[simp]: assumes "(a::'a::idom) ≠ 0" shows "inj (smult a)"
proof-
interpret map_poly_inj_zero_hom "(*) a" using assms by (unfold_locales, auto)
show ?thesis unfolding smult_as_map_poly by (rule inj_f)
qed
definition reconstruct_poly::"'a::idom ⇒ 'a list ⇒ 'a poly" where
"reconstruct_poly c roots = smult c (∏a←roots. [:- a, 1:])"
lemma reconstruct_is_original_poly:
"reconstruct_poly (lead_coeff p) (complex_roots_complex p) = p"
using complex_roots(1) by (simp add: reconstruct_poly_def)
lemma reconstruct_with_type_conversion:
"smult (lead_coeff (map_poly of_int f)) (prod_list (map (λ a. [:- a, 1:]) (complex_roots_int f)))
= map_poly of_int f"
unfolding complex_roots_int_def complex_roots(1) by simp
lemma reconstruct_prod:
shows "reconstruct_poly (a::complex) as * reconstruct_poly b bs
= reconstruct_poly (a * b) (as @ bs)"
unfolding reconstruct_poly_def by auto
lemma linear_term_inj[simplified,simp]: "inj (λ a. [:- a, 1::'a::idom:])"
unfolding inj_on_def by simp
lemma reconstruct_poly_monic_defines_mset:
assumes "(∏a←as. [:- a, 1:]) = (∏a←bs. [:- a, 1::'a::field:])"
shows "mset as = mset bs"
proof -
let ?as = "mset (map (λ a. [:- a, 1:]) as)"
let ?bs = "mset (map (λ a. [:- a, 1:]) bs)"
have eq_smult:"prod_mset ?as = prod_mset ?bs" using assms by (metis prod_mset_prod_list)
have irr:"⋀ as::'a list. set_mset (mset (map (λ a. [:- a, 1:]) as)) ⊆ {q. irreducible q ∧ monic q}"
by (auto intro!: linear_term_irreducible⇩d[of "-_::'a", simplified])
from monic_factorization_unique_mset[OF eq_smult irr irr]
show ?thesis apply (subst inj_eq[OF multiset.inj_map,symmetric]) by auto
qed
lemma reconstruct_poly_defines_mset_of_argument:
assumes "(a::'a::field) ≠ 0"
"reconstruct_poly a as = reconstruct_poly a bs"
shows "mset as = mset bs"
proof -
have eq_smult:"smult a (∏a←as. [:- a, 1:]) = smult a (∏a←bs. [:- a, 1:])"
using assms(2) by (auto simp:reconstruct_poly_def)
from reconstruct_poly_monic_defines_mset[OF Fun.injD[OF smult_inj[OF assms(1)] eq_smult]]
show ?thesis by simp
qed
lemma complex_roots_complex_prod [simp]:
assumes "f ≠ 0" "g ≠ 0"
shows "mset (complex_roots_complex (f * g))
= mset (complex_roots_complex f) + mset (complex_roots_complex g)"
proof -
let ?p = "f * g"
let "?lc v" = "(lead_coeff (v:: complex poly))"
have nonzero_prod:"?lc ?p ≠ 0" using assms by auto
from reconstruct_prod[of "?lc f" "complex_roots_complex f" "?lc g" "complex_roots_complex g"]
have "reconstruct_poly (?lc ?p) (complex_roots_complex ?p)
= reconstruct_poly (?lc ?p) (complex_roots_complex f @ complex_roots_complex g)"
unfolding lead_coeff_mult[symmetric] reconstruct_is_original_poly by auto
from reconstruct_poly_defines_mset_of_argument[OF nonzero_prod this]
show ?thesis by simp
qed
lemma mset_mult_add:
assumes "mset (a::'a::field list) = mset b + mset c"
shows "prod_list a = prod_list b * prod_list c"
unfolding prod_mset_prod_list[symmetric]
using prod_mset_Un[of "mset b" "mset c",unfolded assms[symmetric]].
lemma mset_mult_add_2:
assumes "mset a = mset b + mset c"
shows "prod_list (map i a::'b::field list) = prod_list (map i b) * prod_list (map i c)"
proof -
have r:"mset (map i a) = mset (map i b) + mset (map i c) " using assms
by (metis map_append mset_append mset_map)
show ?thesis using mset_mult_add[OF r] by auto
qed
lemma measure_mono_eq_prod:
assumes "f ≠ 0" "g ≠ 0"
shows "mahler_measure_monic (f * g) = mahler_measure_monic f * mahler_measure_monic g"
unfolding mahler_measure_monic_def
using mset_mult_add_2[OF complex_roots_complex_prod[OF assms],of "λ a. max 1 (cmod a)"] by simp
lemma mahler_measure_poly_0[simp]: "mahler_measure_poly 0 = 0" unfolding mahler_measure_poly_via_monic by auto
lemma measure_eq_prod:
"mahler_measure_poly (f * g) = mahler_measure_poly f * mahler_measure_poly g"
proof -
consider "f = 0" | "g = 0" | (both) "f ≠ 0" "g ≠ 0" by auto
thus ?thesis proof(cases)
case both show ?thesis unfolding mahler_measure_poly_via_monic norm_mult lead_coeff_mult
by (auto simp: measure_mono_eq_prod[OF both])
qed (simp_all)
qed
lemma prod_cmod[simp]:
"cmod (∏a←lst. f a) = (∏a←lst. cmod (f a))"
by(induct lst,auto simp:real_normed_div_algebra_class.norm_mult)
lemma lead_coeff_of_prod[simp]:
"lead_coeff (∏a←lst. f a::'a::idom poly) = (∏a←lst. lead_coeff (f a))"
by(induct lst,auto simp:lead_coeff_mult)
lemma ineq_about_squares:assumes "x ≤ (y::real)" shows "x ≤ c^2 + y" using assms
by (simp add: add.commute add_increasing2)
lemma first_coeff_le_tail:"(cmod (lead_coeff g))^2 ≤ (∑a←coeffs g. (cmod a)^2)"
proof(induct g)
case (pCons a p)
thus ?case proof(cases "p = 0") case False
show ?thesis using pCons unfolding lead_coeff_pCons(1)[OF False]
by(cases "a = 0",simp_all add:ineq_about_squares)
qed simp
qed simp
lemma square_prod_cmod[simp]:
"(cmod (a * b))^2 = cmod a ^ 2 * cmod b ^ 2"
by (simp add: norm_mult power_mult_distrib)
lemma sum_coeffs_smult_cmod:
"(∑a←coeffs (smult v p). (cmod a)^2) = (cmod v)^2 * (∑a←coeffs p. (cmod a)^2)"
(is "?l = ?r")
proof -
have "?l = (∑a←coeffs p. (cmod v)^2 * (cmod a)^2)" by(cases "v=0";induct p,auto)
thus ?thesis by (auto simp:sum_list_const_mult)
qed
abbreviation "linH a ≡ if (cmod a > 1) then [:- 1,cnj a:] else [:- a,1:]"
lemma coeffs_cong_1[simp]: "cCons a v = cCons b v ⟷ a = b" unfolding cCons_def by auto
lemma strip_while_singleton[simp]:
"strip_while ((=) 0) [v * a] = cCons (v * a) []" unfolding cCons_def strip_while_def by auto
lemma coeffs_times_linterm:
shows "coeffs (pCons 0 (smult a p) + smult b p) = strip_while (HOL.eq (0::'a::{comm_ring_1}))
(map (λ(c,d).b*d+c*a) (zip (0 # coeffs p) (coeffs p @ [0])))" proof -
{fix v
have "coeffs (smult b p + pCons (a* v) (smult a p)) = strip_while (HOL.eq 0) (map (λ(c,d).b*d+c*a) (zip ([v] @ coeffs p) (coeffs p @ [0])))"
proof(induct p arbitrary:v) case (pCons pa ps) thus ?case by auto qed auto
}
from this[of 0] show ?thesis by (simp add: add.commute)
qed
lemma filter_distr_rev[simp]:
shows "filter f (rev lst) = rev (filter f lst)"
by(induct lst;auto)
lemma strip_while_filter:
shows "filter ((≠) 0) (strip_while ((=) 0) (lst::'a::zero list)) = filter ((≠) 0) lst"
proof - {fix lst::"'a list"
have "filter ((≠) 0) (dropWhile ((=) 0) lst) = filter ((≠) 0) lst" by (induct lst;auto)
hence "(filter ((≠) 0) (strip_while ((=) 0) (rev lst))) = filter ((≠) 0) (rev lst)"
unfolding strip_while_def by(simp)}
from this[of "rev lst"] show ?thesis by simp
qed
lemma sum_stripwhile[simp]:
assumes "f 0 = 0"
shows "(∑a←strip_while ((=) 0) lst. f a) = (∑a←lst. f a)"
proof -
{fix lst
have "(∑a←filter ((≠) 0) lst. f a) = (∑a←lst. f a)" by(induct lst,auto simp:assms)}
note f=this
have "sum_list (map f (filter ((≠) 0) (strip_while ((=) 0) lst)))
= sum_list (map f (filter ((≠) 0) lst))"
using strip_while_filter[of lst] by(simp)
thus ?thesis unfolding f.
qed
lemma complex_split : "Complex a b = c ⟷ (a = Re c ∧ b = Im c)"
using complex_surj by auto
lemma norm_times_const:"(∑y←lst. (cmod (a * y))⇧2) = (cmod a)⇧2 * (∑y←lst. (cmod y)⇧2)"
by(induct lst,auto simp:ring_distribs)
fun bisumTail where
"bisumTail f (Cons a (Cons b bs)) = f a b + bisumTail f (Cons b bs)" |
"bisumTail f (Cons a Nil) = f a 0" |
"bisumTail f Nil = f 1 0"
fun bisum where
"bisum f (Cons a as) = f 0 a + bisumTail f (Cons a as)" |
"bisum f Nil = f 0 0"
lemma bisumTail_is_map_zip:
"(∑x←zip (v # l1) (l1 @ [0]). f x) = bisumTail (λx y .f (x,y)) (v#l1)"
by(induct l1 arbitrary:v,auto)
lemma bisum_is_map_zip:
"(∑x←zip (0 # l1) (l1 @ [0]). f x) = bisum (λx y. f (x,y)) l1"
using bisumTail_is_map_zip[of f "hd l1" "tl l1"] by(cases l1,auto)
lemma map_zip_is_bisum:
"bisum f l1 = (∑(x,y)←zip (0 # l1) (l1 @ [0]). f x y)"
using bisum_is_map_zip[of "λ(x,y). f x y"] by auto
lemma bisum_outside :
"(bisum (λ x y. f1 x - f2 x y + f3 y) lst :: 'a :: field)
= sum_list (map f1 lst) + f1 0 - bisum f2 lst + sum_list (map f3 lst) + f3 0"
proof(cases lst)
case (Cons a lst) show ?thesis unfolding map_zip_is_bisum Cons by(induct lst arbitrary:a,auto)
qed auto
lemma Landau_lemma:
"(∑a←coeffs (∏a←lst. [:- a, 1:]). (cmod a)⇧2) = (∑a←coeffs (∏a←lst. linH a). (cmod a)⇧2)"
(is "norm2 ?l = norm2 ?r")
proof -
have a:"⋀ a. (cmod a)⇧2 = Re (a * cnj a) " using complex_norm_square
unfolding complex_split complex_of_real_def by simp
have b:"⋀ x a y. (cmod (x - a * y))^2
= (cmod x)⇧2 - Re (a * y * cnj x + x * cnj (a * y)) + (cmod (a * y))^2"
unfolding left_diff_distrib right_diff_distrib a complex_cnj_diff by simp
have c:"⋀ y a x. (cmod (cnj a * x - y))⇧2
= (cmod (a * x))⇧2 - Re (a * y * cnj x + x * cnj (a * y)) + (cmod y)^2"
unfolding left_diff_distrib right_diff_distrib a complex_cnj_diff
by (simp add: mult.assoc mult.left_commute)
{ fix f1 a
have "norm2 ([:- a, 1 :] * f1) = bisum (λx y. cmod (x - a * y)^2) (coeffs f1)"
by(simp add: bisum_is_map_zip[of _ "coeffs f1"] coeffs_times_linterm[of 1 _ "-a",simplified])
also have "… = norm2 f1 + cmod a^2*norm2 f1
- bisum (λx y. Re (a * y * cnj x + x * cnj (a * y))) (coeffs f1)"
unfolding b bisum_outside norm_times_const by simp
also have "… = bisum (λx y. cmod (cnj a * x - y)^2) (coeffs f1)"
unfolding c bisum_outside norm_times_const by auto
also have "… = norm2 ([:- 1, cnj a :] * f1)"
using coeffs_times_linterm[of "cnj a" _ "-1"]
by(simp add: bisum_is_map_zip[of _ "coeffs f1"] mult.commute)
finally have "norm2 ([:- a, 1 :] * f1) = …".}
hence h:"⋀ a f1. norm2 ([:- a, 1 :] * f1) = norm2 (linH a * f1)" by auto
show ?thesis by(rule prod_induct_gen[OF h])
qed
lemma Landau_inequality:
"mahler_measure_poly f ≤ l2norm_complex f"
proof -
let ?f = "reconstruct_poly (lead_coeff f) (complex_roots_complex f)"
let ?roots = "(complex_roots_complex f)"
let ?g = "∏a←?roots. linH a"
have max:"⋀a. cmod (if 1 < cmod a then cnj a else 1) = max 1 (cmod a)" by(simp add:if_split,auto)
have "⋀a. 1 < cmod a ⟹ a ≠ 0" by auto
hence "⋀a. lead_coeff (linH a) = (if (cmod a > 1) then cnj a else 1)" by(auto simp:if_split)
hence lead_coeff_g:"cmod (lead_coeff ?g) = (∏a←?roots. max 1 (cmod a))" by(auto simp:max)
have "norm2 f = (∑a←coeffs ?f. (cmod a)^2)" unfolding reconstruct_is_original_poly..
also have "… = cmod (lead_coeff f)^2 * (∑a←coeffs (∏a←?roots. [:- a, 1:]). (cmod a)⇧2)"
unfolding reconstruct_poly_def using sum_coeffs_smult_cmod.
finally have fg_norm:"norm2 f = cmod (lead_coeff f)^2 * (∑a←coeffs ?g. (cmod a)^2)"
unfolding Landau_lemma by auto
have "(cmod (lead_coeff ?g))^2 ≤ (∑a←coeffs ?g. (cmod a)^2)"
using first_coeff_le_tail by blast
from ordered_comm_semiring_class.comm_mult_left_mono[OF this]
have "(cmod (lead_coeff f) * cmod (lead_coeff ?g))^2 ≤ (∑a←coeffs f. (cmod a)^2)"
unfolding fg_norm by (simp add:power_mult_distrib)
hence "cmod (lead_coeff f) * (∏a←?roots. max 1 (cmod a)) ≤ sqrt (norm2 f)"
using NthRoot.real_le_rsqrt lead_coeff_g by auto
thus "mahler_measure_poly f ≤ sqrt (norm2 f)"
using reconstruct_with_type_conversion[unfolded complex_roots_int_def]
by (simp add: mahler_measure_poly_via_monic mahler_measure_monic_def complex_roots_int_def)
qed
lemma prod_list_ge1:
assumes "Ball (set x) (λ (a::real). a ≥ 1)"
shows "prod_list x ≥ 1"
using assms proof(induct x)
case (Cons a as)
have "∀a∈set as. 1 ≤ a" "1 ≤ a" using Cons(2) by auto
thus ?case using Cons.hyps mult_mono' by fastforce
qed auto
lemma mahler_measure_monic_ge_1: "mahler_measure_monic p ≥ 1"
unfolding mahler_measure_monic_def by(rule prod_list_ge1,simp)
lemma mahler_measure_monic_ge_0: "mahler_measure_monic p ≥ 0"
using mahler_measure_monic_ge_1 le_numeral_extra(1) order_trans by blast
lemma mahler_measure_ge_0: "0 ≤ mahler_measure h" unfolding mahler_measure_def mahler_measure_poly_via_monic
by (simp add: mahler_measure_monic_ge_0)
lemma mahler_measure_constant[simp]: "mahler_measure_poly [:c:] = cmod c"
proof -
have main: "complex_roots_complex [:c:] = []" unfolding complex_roots_complex_def
by (rule some_equality, auto)
show ?thesis unfolding mahler_measure_poly_def main by auto
qed
lemma mahler_measure_factor[simplified,simp]: "mahler_measure_poly [:- a, 1:] = max 1 (cmod a)"
proof -
have main: "complex_roots_complex [:- a, 1:] = [a]" unfolding complex_roots_complex_def
proof (rule some_equality, auto, goal_cases)
case (1 as)
thus ?case by (cases as, auto)
qed
show ?thesis unfolding mahler_measure_poly_def main by auto
qed
lemma mahler_measure_poly_explicit: "mahler_measure_poly (smult c (∏a←as. [:- a, 1:]))
= cmod c * (∏a←as. (max 1 (cmod a)))"
proof (cases "c = 0")
case True
thus ?thesis by auto
next
case False note c = this
show ?thesis
proof (induct as)
case (Cons a as)
have "mahler_measure_poly (smult c (∏a←a # as. [:- a, 1:]))
= mahler_measure_poly (smult c (∏a←as. [:- a, 1:]) * [: -a, 1 :])"
by (rule arg_cong[of _ _ mahler_measure_poly], unfold list.simps prod_list.Cons mult_smult_left, simp)
also have "… = mahler_measure_poly (smult c (∏a←as. [:- a, 1:])) * mahler_measure_poly ([:- a, 1:])"
(is "_ = ?l * ?r") by (rule measure_eq_prod)
also have "?l = cmod c * (∏a←as. max 1 (cmod a))" unfolding Cons by simp
also have "?r = max 1 (cmod a)" by simp
finally show ?case by simp
next
case Nil
show ?case by simp
qed
qed
lemma mahler_measure_poly_ge_1:
assumes "h ≠ 0"
shows "(1::real) ≤ mahler_measure h"
proof -
have rc: "¦real_of_int i¦ = of_int ¦i¦" for i by simp
from assms have "cmod (lead_coeff (map_poly complex_of_int h)) > 0" by simp
hence "cmod (lead_coeff (map_poly complex_of_int h)) ≥ 1"
by(cases "lead_coeff h = 0", auto simp del: leading_coeff_0_iff)
from mult_mono[OF this mahler_measure_monic_ge_1 norm_ge_zero]
show ?thesis unfolding mahler_measure_def mahler_measure_poly_via_monic
by auto
qed
lemma mahler_measure_dvd: assumes "f ≠ 0" and "h dvd f"
shows "mahler_measure h ≤ mahler_measure f"
proof -
from assms obtain g where f: "f = g * h" unfolding dvd_def by auto
from f assms have g0: "g ≠ 0" by auto
hence mg: "mahler_measure g ≥ 1" by (rule mahler_measure_poly_ge_1)
have "1 * mahler_measure h ≤ mahler_measure f"
unfolding mahler_measure_def f measure_eq_prod
of_int_poly_hom.hom_mult unfolding mahler_measure_def[symmetric]
by (rule mult_right_mono[OF mg mahler_measure_ge_0])
thus ?thesis by simp
qed
definition graeffe_poly :: "'a ⇒ 'a :: comm_ring_1 list ⇒ nat ⇒ 'a poly" where
"graeffe_poly c as m = smult (c ^ (2^m)) (∏a←as. [:- (a ^ (2^m)), 1:])"
context
fixes f :: "complex poly" and c as
assumes f: "f = smult c (∏a←as. [:- a, 1:])"
begin
lemma mahler_graeffe: "mahler_measure_poly (graeffe_poly c as m) = (mahler_measure_poly f)^(2^m)"
proof -
have graeffe: "graeffe_poly c as m = smult (c ^ 2 ^ m) (∏a←(map (λ a. a ^ 2 ^ m) as). [:- a, 1:])"
unfolding graeffe_poly_def
by (rule arg_cong[of _ _ "smult (c ^ 2 ^ m)"], induct as, auto)
{
fix n :: nat
assume n: "n > 0"
have id: "max 1 (cmod a ^ n) = max 1 (cmod a) ^ n" for a
proof (cases "cmod a ≤ 1")
case True
hence "cmod a ^ n ≤ 1" by (simp add: power_le_one)
with True show ?thesis by (simp add: max_def)
qed (auto simp: max_def)
have "(∏x←as. max 1 (cmod x ^ n)) = (∏a←as. max 1 (cmod a)) ^ n"
by (induct as, auto simp: field_simps n id)
}
thus ?thesis unfolding f mahler_measure_poly_explicit graeffe
by (auto simp: o_def field_simps norm_power)
qed
end
fun drop_half :: "'a list ⇒ 'a list" where
"drop_half (x # y # ys) = x # drop_half ys"
| "drop_half xs = xs"
fun alternate :: "'a list ⇒ 'a list × 'a list" where
"alternate (x # y # ys) = (case alternate ys of (evn, od) ⇒ (x # evn, y # od))"
| "alternate xs = (xs,[])"
definition poly_square_subst :: "'a :: comm_ring_1 poly ⇒ 'a poly" where
"poly_square_subst f = poly_of_list (drop_half (coeffs f))"
definition poly_even_odd :: "'a :: comm_ring_1 poly ⇒ 'a poly × 'a poly" where
"poly_even_odd f = (case alternate (coeffs f) of (evn,od) ⇒ (poly_of_list evn, poly_of_list od))"
lemma poly_square_subst_coeff: "coeff (poly_square_subst f) i = coeff f (2 * i)"
proof -
have id: "coeff f (2 * i) = coeff (Poly (coeffs f)) (2 * i)" by simp
obtain xs where xs: "coeffs f = xs" by auto
show ?thesis unfolding poly_square_subst_def poly_of_list_def coeff_Poly_eq id xs
proof (induct xs arbitrary: i rule: drop_half.induct)
case (1 x y ys i) thus ?case by (cases i, auto)
next
case ("2_2" x i) thus ?case by (cases i, auto)
qed auto
qed
lemma poly_even_odd_coeff: assumes "poly_even_odd f = (ev,od)"
shows "coeff ev i = coeff f (2 * i)" "coeff od i = coeff f (2 * i + 1)"
proof -
have id: "⋀ i. coeff f i = coeff (Poly (coeffs f)) i" by simp
obtain xs where xs: "coeffs f = xs" by auto
from assms[unfolded poly_even_odd_def]
have ev_od: "ev = Poly (fst (alternate xs))" "od = Poly (snd (alternate xs))"
by (auto simp: xs split: prod.splits)
have "coeff ev i = coeff f (2 * i) ∧ coeff od i = coeff f (2 * i + 1)"
unfolding poly_of_list_def coeff_Poly_eq id xs ev_od
proof (induct xs arbitrary: i rule: alternate.induct)
case (1 x y ys i) thus ?case by (cases "alternate ys"; cases i, auto)
next
case ("2_2" x i) thus ?case by (cases i, auto)
qed auto
thus "coeff ev i = coeff f (2 * i)" "coeff od i = coeff f (2 * i + 1)" by auto
qed
lemma poly_square_subst: "poly_square_subst (f ∘⇩p (monom 1 2)) = f"
by (rule poly_eqI, unfold poly_square_subst_coeff, subst coeff_pcompose_x_pow_n, auto)
lemma poly_even_odd: assumes "poly_even_odd f = (g,h)"
shows "f = g ∘⇩p monom 1 2 + monom 1 1 * (h ∘⇩p monom 1 2)"
proof -
note id = poly_even_odd_coeff[OF assms]
show ?thesis
proof (rule poly_eqI, unfold coeff_add coeff_monom_mult)
fix n :: nat
obtain m i where mi: "m = n div 2" "i = n mod 2" by auto
have nmi: "n = 2 * m + i" "i < 2" "0 < (2 :: nat)" "1 < (2 :: nat)" unfolding mi by auto
have "(2 :: nat) ≠ 0" by auto
show "coeff f n = coeff (g ∘⇩p monom 1 2) n + (if 1 ≤ n then 1 * coeff (h ∘⇩p monom 1 2) (n - 1) else 0)"
proof (cases "i = 1")
case True
hence id1: "2 * m + i - 1 = 2 * m + 0" by auto
show ?thesis unfolding nmi id id1 coeff_pcompose_monom[OF nmi(2)] coeff_pcompose_monom[OF nmi(3)]
unfolding True by auto
next
case False
with nmi have i0: "i = 0" by auto
show ?thesis
proof (cases m)
case (Suc k)
hence id1: "2 * m + i - 1 = 2 * k + 1" using i0 by auto
show ?thesis unfolding nmi id coeff_pcompose_monom[OF nmi(2)]
coeff_pcompose_monom[OF nmi(4)] id1 unfolding Suc i0 by auto
next
case 0
show ?thesis unfolding nmi id coeff_pcompose_monom[OF nmi(2)] unfolding i0 0 by auto
qed
qed
qed
qed
context
fixes f :: "'a :: idom poly"
begin
lemma graeffe_0: "f = smult c (∏a←as. [:- a, 1:]) ⟹ graeffe_poly c as 0 = f"
unfolding graeffe_poly_def by auto
lemma graeffe_recursion: assumes "graeffe_poly c as m = f"
shows "graeffe_poly c as (Suc m) = smult ((-1)^(degree f)) (poly_square_subst (f * f ∘⇩p [:0,-1:]))"
proof -
let ?g = "graeffe_poly c as m"
have "f * f ∘⇩p [:0,-1:] = ?g * ?g ∘⇩p [:0,-1:]" unfolding assms by simp
also have "?g ∘⇩p [:0,-1:] = smult ((- 1) ^ length as) (smult (c ^ 2 ^ m) (∏a←as. [:a ^ 2 ^ m, 1:]))"
unfolding graeffe_poly_def
proof (induct as)
case (Cons a as)
have "?case = ((smult (c ^ 2 ^ m) ([:- (a ^ 2 ^ m), 1:] ∘⇩p [:0, - 1:] * (∏a←as. [:- (a ^ 2 ^ m), 1:]) ∘⇩p [:0, - 1:]) =
smult (-1 * (- 1) ^ length as)
(smult (c ^ 2 ^ m) ([: a ^ 2 ^ m, 1:] * (∏a←as. [:a ^ 2 ^ m, 1:])))))"
unfolding list.simps prod_list.Cons pcompose_smult pcompose_mult by simp
also have "smult (c ^ 2 ^ m) ([:- (a ^ 2 ^ m), 1:] ∘⇩p [:0, - 1:] * (∏a←as. [:- (a ^ 2 ^ m), 1:]) ∘⇩p [:0, - 1:])
= smult (c ^ 2 ^ m) ((∏a←as. [:- (a ^ 2 ^ m), 1:]) ∘⇩p [:0, - 1:]) * [:- (a ^ 2 ^ m), 1:] ∘⇩p [:0, - 1:]"
unfolding mult_smult_left by simp
also have "smult (c ^ 2 ^ m) ((∏a←as. [:- (a ^ 2 ^ m), 1:]) ∘⇩p [:0, - 1:]) =
smult ((- 1) ^ length as) (smult (c ^ 2 ^ m) (∏a←as. [:a ^ 2 ^ m, 1:]))"
unfolding pcompose_smult[symmetric] Cons ..
also have "[:- (a ^ 2 ^ m), 1:] ∘⇩p [:0, - 1:] = smult (-1) [: a^2^m, 1:]" by simp
finally have id: "?case = (smult ((- 1) ^ length as) (smult (c ^ 2 ^ m) (∏a←as. [:a ^ 2 ^ m, 1:])) * smult (- 1) [:a ^ 2 ^ m, 1:] =
smult (- 1 * (- 1) ^ length as) (smult (c ^ 2 ^ m) ([:a ^ 2 ^ m, 1:] * (∏a←as. [:a ^ 2 ^ m, 1:]))))" by simp
obtain c d where id': "(∏a←as. [:a ^ 2 ^ m, 1:]) = c" "[:a ^ 2 ^ m, 1:] = d" by auto
show ?case unfolding id unfolding id' by (simp add: ac_simps)
qed simp
finally have "f * f ∘⇩p [:0, - 1:] =
smult ((- 1) ^ length as * (c ^ 2 ^ m * c ^ 2 ^ m))
((∏a←as. [:- (a ^ 2 ^ m), 1:]) * (∏a←as. [:a ^ 2 ^ m, 1:]))"
unfolding graeffe_poly_def by (simp add: ac_simps)
also have "c ^ 2 ^ m * c ^ 2 ^ m = c ^ 2 ^ (Suc m)" by (simp add: semiring_normalization_rules(36))
also have "(∏a←as. [:- (a ^ 2 ^ m), 1:]) * (∏a←as. [:a ^ 2 ^ m, 1:]) =
(∏a←as. [:- (a ^ 2 ^ (Suc m)), 1:]) ∘⇩p monom 1 2"
proof (induct as)
case (Cons a as)
have id: "(monom 1 2 :: 'a poly) = [:0,0,1:]"
by (metis monom_altdef pCons_0_as_mult power2_eq_square smult_1_left)
have "(∏a←a # as. [:- (a ^ 2 ^ m), 1:]) * (∏a←a # as. [:a ^ 2 ^ m, 1:])
= ([:- (a ^ 2 ^ m), 1:] * [: a ^ 2 ^ m, 1:]) * ((∏a← as. [:- (a ^ 2 ^ m), 1:]) * (∏a← as. [:a ^ 2 ^ m, 1:]))"
(is "_ = ?a * ?b")
unfolding list.simps prod_list.Cons by (simp only: ac_simps)
also have "?b = (∏a←as. [:- (a ^ 2 ^ Suc m), 1:]) ∘⇩p monom 1 2" unfolding Cons by simp
also have "?a = [: - (a ^ 2 ^ (Suc m)), 0 , 1:]" by (simp add: semiring_normalization_rules(36))
also have "… = [: - (a ^ 2 ^ (Suc m)), 1:] ∘⇩p monom 1 2" by (simp add: id)
also have "[: - (a ^ 2 ^ (Suc m)), 1:] ∘⇩p monom 1 2 * (∏a←as. [:- (a ^ 2 ^ Suc m), 1:]) ∘⇩p monom 1 2 =
(∏a←a # as. [:- (a ^ 2 ^ Suc m), 1:]) ∘⇩p monom 1 2" unfolding pcompose_mult[symmetric] by simp
finally show ?case .
qed simp
finally have "f * f ∘⇩p [:0, - 1:] = (smult ((- 1) ^ length as) (graeffe_poly c as (Suc m)) ∘⇩p monom 1 2)"
unfolding graeffe_poly_def pcompose_smult by simp
from arg_cong[OF this, of "λ f. smult ((- 1) ^ length as) (poly_square_subst f)", unfolded poly_square_subst]
have "graeffe_poly c as (Suc m) = smult ((- 1) ^ length as) (poly_square_subst (f * f ∘⇩p [:0, - 1:]))" by simp
also have "… = smult ((- 1) ^ degree f) (poly_square_subst (f * f ∘⇩p [:0, - 1:]))"
proof (cases "f = 0")
case True
thus ?thesis by (auto simp: poly_square_subst_def)
next
case False
with assms have c0: "c ≠ 0" unfolding graeffe_poly_def by auto
from arg_cong[OF assms, of degree]
have "degree f = degree (smult (c ^ 2 ^ m) (∏a←as. [:- (a ^ 2 ^ m), 1:]))" unfolding graeffe_poly_def by auto
also have "… = degree (∏a←as. [:- (a ^ 2 ^ m), 1:])" unfolding degree_smult_eq using c0 by auto
also have "… = length as" unfolding degree_linear_factors by simp
finally show ?thesis by simp
qed
finally show ?thesis .
qed
end
definition graeffe_one_step :: "'a ⇒ 'a :: idom poly ⇒ 'a poly" where
"graeffe_one_step c f = smult c (poly_square_subst (f * f ∘⇩p [:0,-1:]))"
lemma graeffe_one_step_code[code]: fixes c :: "'a :: idom"
shows "graeffe_one_step c f = (case poly_even_odd f of (g,h)
⇒ smult c (g * g - monom 1 1 * h * h))"
proof -
obtain g h where eo: "poly_even_odd f = (g,h)" by force
from poly_even_odd[OF eo] have fgh: "f = g ∘⇩p monom 1 2 + monom 1 1 * h ∘⇩p monom 1 2 " by auto
have m2: "monom (1 :: 'a) 2 = [:0,0,1:]" "monom (1 :: 'a) 1 = [:0,1:]"
unfolding coeffs_eq_iff coeffs_monom
by (auto simp add: numeral_2_eq_2)
show ?thesis unfolding eo split graeffe_one_step_def
proof (rule arg_cong[of _ _ "smult c"])
let ?g = "g ∘⇩p monom 1 2"
let ?h = "h ∘⇩p monom 1 2"
let ?x = "monom (1 :: 'a) 1"
have 2: "2 = Suc (Suc 0)" by simp
have "f * f ∘⇩p [:0, - 1:] = (g ∘⇩p monom 1 2 + monom 1 1 * h ∘⇩p monom 1 2) *
(g ∘⇩p monom 1 2 + monom 1 1 * h ∘⇩p monom 1 2) ∘⇩p [:0, - 1:]" unfolding fgh by simp
also have "(g ∘⇩p monom 1 2 + monom 1 1 * h ∘⇩p monom 1 2) ∘⇩p [:0, - 1:]
= g ∘⇩p (monom 1 2 ∘⇩p [:0, - 1:]) + monom 1 1 ∘⇩p [:0, - 1:] * h ∘⇩p (monom 1 2 ∘⇩p [:0, - 1:])"
unfolding pcompose_add pcompose_mult pcompose_assoc by simp
also have "monom (1 :: 'a) 2 ∘⇩p [:0, - 1:] = monom 1 2" unfolding m2 by auto
also have "?x ∘⇩p [:0, - 1:] = [:0, -1:]" unfolding m2 by auto
also have "[:0, - 1:] * h ∘⇩p monom 1 2 = (-?x) * ?h" unfolding m2 by simp
also have "(?g + ?x * ?h) * (?g + (- ?x) * ?h) = (?g * ?g - (?x * ?x) * ?h * ?h)"
by (auto simp: field_simps)
also have "?x * ?x = ?x ∘⇩p monom 1 2" unfolding mult_monom by (insert m2, simp add: 2)
also have "(?g * ?g - … * ?h * ?h) = (g * g - ?x * h * h) ∘⇩p monom 1 2"
unfolding pcompose_diff pcompose_mult by auto
finally have "poly_square_subst (f * f ∘⇩p [:0, - 1:])
= poly_square_subst ((g * g - ?x * h * h) ∘⇩p monom 1 2)" by simp
also have "… = g * g - ?x * h * h" unfolding poly_square_subst by simp
finally show "poly_square_subst (f * f ∘⇩p [:0, - 1:]) = g * g - ?x * h * h" .
qed
qed
fun graeffe_poly_impl_main :: "'a ⇒ 'a :: idom poly ⇒ nat ⇒ 'a poly" where
"graeffe_poly_impl_main c f 0 = f"
| "graeffe_poly_impl_main c f (Suc m) = graeffe_one_step c (graeffe_poly_impl_main c f m)"
lemma graeffe_poly_impl_main: assumes "f = smult c (∏a←as. [:- a, 1:])"
shows "graeffe_poly_impl_main ((-1)^degree f) f m = graeffe_poly c as m"
proof (induct m)
case 0
show ?case using graeffe_0[OF assms] by simp
next
case (Suc m)
have [simp]: "degree (graeffe_poly c as m) = degree f" unfolding graeffe_poly_def degree_smult_eq assms
degree_linear_factors by auto
from arg_cong[OF Suc, of degree]
show ?case unfolding graeffe_recursion[OF Suc[symmetric]]
by (simp add: graeffe_one_step_def)
qed
definition graeffe_poly_impl :: "'a :: idom poly ⇒ nat ⇒ 'a poly" where
"graeffe_poly_impl f = graeffe_poly_impl_main ((-1)^(degree f)) f"
lemma graeffe_poly_impl: assumes "f = smult c (∏a←as. [:- a, 1:])"
shows "graeffe_poly_impl f m = graeffe_poly c as m"
using graeffe_poly_impl_main[OF assms] unfolding graeffe_poly_impl_def .
lemma drop_half_map: "drop_half (map f xs) = map f (drop_half xs)"
by (induct xs rule: drop_half.induct, auto)
lemma (in inj_comm_ring_hom) map_poly_poly_square_subst:
"map_poly hom (poly_square_subst f) = poly_square_subst (map_poly hom f)"
unfolding poly_square_subst_def coeffs_map_poly_hom drop_half_map poly_of_list_def
by (rule poly_eqI, auto simp: nth_default_map_eq)
context inj_idom_hom
begin
lemma graeffe_poly_impl_hom:
"map_poly hom (graeffe_poly_impl f m) = graeffe_poly_impl (map_poly hom f) m"
proof -
interpret mh: map_poly_inj_idom_hom..
obtain c where c: "(((- 1) ^ degree f) :: 'a) = c" by auto
have c': "(((- 1) ^ degree f) :: 'b) = hom c" unfolding c[symmetric] by (simp add:hom_distribs)
show ?thesis unfolding graeffe_poly_impl_def degree_map_poly_hom c c'
apply (induct m arbitrary: f; simp)
by (unfold graeffe_one_step_def hom_distribs map_poly_poly_square_subst map_poly_pcompose,simp)
qed
end
lemma graeffe_poly_impl_mahler: "mahler_measure (graeffe_poly_impl f m) = mahler_measure f ^ 2 ^ m"
proof -
let ?c = "complex_of_int"
let ?cc = "map_poly ?c"
let ?f = "?cc f"
note eq = complex_roots(1)[of ?f]
interpret inj_idom_hom complex_of_int by (standard, auto)
show ?thesis
unfolding mahler_measure_def mahler_graeffe[OF eq[symmetric], symmetric]
graeffe_poly_impl[OF eq[symmetric], symmetric] by (simp add: of_int_hom.graeffe_poly_impl_hom)
qed
definition mahler_landau_graeffe_approximation :: "nat ⇒ nat ⇒ int poly ⇒ int" where
"mahler_landau_graeffe_approximation kk dd f = (let
no = sum_list (map (λ a. a * a) (coeffs f))
in root_int_floor kk (dd * no))"
lemma mahler_landau_graeffe_approximation_core:
assumes g: "g = graeffe_poly_impl f k"
shows "mahler_measure f ≤ root (2 ^ Suc k) (real_of_int (∑a←coeffs g. a * a))"
proof -
have "mahler_measure f = root (2^k) (mahler_measure f ^ (2^k))"
by (simp add: real_root_power_cancel mahler_measure_ge_0)
also have "… = root (2^k) (mahler_measure g)"
unfolding graeffe_poly_impl_mahler g by simp
also have "… = root (2^k) (root 2 (((mahler_measure g)^2)))"
by (simp add: real_root_power_cancel mahler_measure_ge_0)
also have "… = root (2^Suc k) (((mahler_measure g)^2))"
by (metis power_Suc2 real_root_mult_exp)
also have "… ≤ root (2 ^ Suc k) (real_of_int (∑a←coeffs g. a * a))"
proof (rule real_root_le_mono, force)
have square_mono: "0 ≤ (x :: real) ⟹ x ≤ y ⟹ x * x ≤ y * y" for x y
by (simp add: mult_mono')
obtain gs where gs: "coeffs g = gs" by auto
have "(mahler_measure g)⇧2 ≤ real_of_int ¦∑a←coeffs g. a * a¦"
using square_mono[OF mahler_measure_ge_0 Landau_inequality[of "of_int_poly g", folded mahler_measure_def]]
by (auto simp: power2_eq_square coeffs_map_poly o_def of_int_hom.hom_sum_list)
also have "¦∑a←coeffs g. a * a¦ = (∑a←coeffs g. a * a)" unfolding gs
by (induct gs, auto)
finally show "(mahler_measure g)⇧2 ≤ real_of_int (∑a←coeffs g. a * a)" .
qed
finally show "mahler_measure f ≤ root (2 ^ Suc k) (real_of_int (∑a←coeffs g. a * a))" .
qed
lemma Landau_inequality_mahler_measure: "mahler_measure f ≤ sqrt (real_of_int (∑a←coeffs f. a * a))"
by (rule order.trans[OF mahler_landau_graeffe_approximation_core[OF refl, of _ 0]],
auto simp: graeffe_poly_impl_def sqrt_def)
lemma mahler_landau_graeffe_approximation:
assumes g: "g = graeffe_poly_impl f k" "dd = d^(2^(Suc k))" "kk = 2^(Suc k)"
shows "⌊real d * mahler_measure f⌋ ≤ mahler_landau_graeffe_approximation kk dd g"
proof -
have id1: "real_of_int (int (d ^ 2 ^ Suc k)) = (real d) ^ 2 ^ Suc k" by simp
have id2: "root (2 ^ Suc k) (real d ^ 2 ^ Suc k) = real d"
by (simp add: real_root_power_cancel)
show ?thesis unfolding mahler_landau_graeffe_approximation_def Let_def root_int_floor of_int_mult g(2-3)
by (rule floor_mono, unfold real_root_mult id1 id2, rule mult_left_mono,
rule mahler_landau_graeffe_approximation_core[OF g(1)], auto)
qed
context
fixes bnd :: nat
begin
function mahler_approximation_main :: "nat ⇒ int ⇒ int poly ⇒ int ⇒ nat ⇒ nat ⇒ int" where
"mahler_approximation_main dd c g mm k kk = (let mmm = mahler_landau_graeffe_approximation kk dd g;
new_mm = (if k = 0 then mmm else min mm mmm)
in (if k ≥ bnd then new_mm else
mahler_approximation_main (dd * dd) c (graeffe_one_step c g) new_mm (Suc k) (2 * kk)))"
by pat_completeness auto
termination by (relation "measure (λ (dd,c,f,mm,k,kk). Suc bnd - k)", auto)
declare mahler_approximation_main.simps[simp del]
lemma mahler_approximation_main: assumes "k ≠ 0 ⟹ ⌊real d * mahler_measure f⌋ ≤ mm"
and "c = (-1)^(degree f)"
and "g = graeffe_poly_impl_main c f k" "dd = d^(2^(Suc k))" "kk = 2^(Suc k)"
shows "⌊real d * mahler_measure f⌋ ≤ mahler_approximation_main dd c g mm k kk"
using assms
proof (induct c g mm k kk rule: mahler_approximation_main.induct)
case (1 dd c g mm k kk)
let ?df = "⌊real d * mahler_measure f⌋"
note dd = 1(5)
note kk = 1(6)
note g = 1(4)
note c = 1(3)
note mm = 1(2)
note IH = 1(1)
note mahl = mahler_approximation_main.simps[of dd c g mm k kk]
define mmm where "mmm = mahler_landau_graeffe_approximation kk dd g"
define new_mm where "new_mm = (if k = 0 then mmm else min mm mmm)"
let ?cond = "bnd ≤ k"
have id: "mahler_approximation_main dd c g mm k kk = (if ?cond then new_mm
else mahler_approximation_main (dd * dd) c (graeffe_one_step c g) new_mm (Suc k) (2 * kk))"
unfolding mahl mmm_def[symmetric] Let_def new_mm_def[symmetric] by simp
have gg: "g = (graeffe_poly_impl f k)" unfolding g graeffe_poly_impl_def c ..
from mahler_landau_graeffe_approximation[OF gg dd kk, folded mmm_def]
have mmm: "?df ≤ mmm" .
with mm have new_mm: "?df ≤ new_mm" unfolding new_mm_def by auto
show ?case
proof (cases ?cond)
case True
show ?thesis unfolding id using True new_mm by auto
next
case False
hence id: "mahler_approximation_main dd c g mm k kk =
mahler_approximation_main (dd * dd) c (graeffe_one_step c g) new_mm (Suc k) (2 * kk)"
unfolding id by auto
have id': "graeffe_one_step c g = graeffe_poly_impl_main c f (Suc k)"
unfolding g by simp
have "dd * dd = d ^ 2 ^ Suc (Suc k)" "2 * kk = 2 ^ Suc (Suc k)" unfolding dd kk
semiring_normalization_rules(26) by auto
from IH[OF mmm_def new_mm_def False new_mm c id' this]
show ?thesis unfolding id .
qed
qed
definition mahler_approximation :: "nat ⇒ int poly ⇒ int" where
"mahler_approximation d f = mahler_approximation_main (d * d) ((-1)^(degree f)) f (-1) 0 2"
lemma mahler_approximation: "⌊real d * mahler_measure f⌋ ≤ mahler_approximation d f"
unfolding mahler_approximation_def
by (rule mahler_approximation_main, auto simp: semiring_normalization_rules(29))
end
end
Theory Factor_Bound
subsection ‹The Mignotte Bound›
theory Factor_Bound
imports
Mahler_Measure
Polynomial_Factorization.Gauss_Lemma
Subresultants.Coeff_Int
begin
lemma binomial_mono_left: "n ≤ N ⟹ n choose k ≤ N choose k"
proof (induct n arbitrary: k N)
case (0 k N)
thus ?case by (cases k, auto)
next
case (Suc n k N) note IH = this
show ?case
proof (cases k)
case (Suc kk)
from IH obtain NN where N: "N = Suc NN" and le: "n ≤ NN" by (cases N, auto)
show ?thesis unfolding N Suc using IH(1)[OF le]
by (simp add: add_le_mono)
qed auto
qed
definition choose_int where "choose_int m n = (if n < 0 then 0 else m choose (nat n))"
lemma choose_int_suc[simp]:
"choose_int (Suc n) i = choose_int n (i-1) + choose_int n i"
proof(cases "nat i")
case 0 thus ?thesis by (simp add:choose_int_def) next
case (Suc v) hence "nat (i - 1) = v" "i≠0" by simp_all
thus ?thesis unfolding choose_int_def Suc by simp
qed
lemma sum_le_1_prod: assumes d: "1 ≤ d" and c: "1 ≤ c"
shows "c + d ≤ 1 + c * (d :: real)"
proof -
from d c have "(c - 1) * (d - 1) ≥ 0" by auto
thus ?thesis by (auto simp: field_simps)
qed
lemma mignotte_helper_coeff_int: "cmod (coeff_int (∏a←lst. [:- a, 1:]) i)
≤ choose_int (length lst - 1) i * (∏a←lst. (max 1 (cmod a)))
+ choose_int (length lst - 1) (i - 1)"
proof(induct lst arbitrary:i)
case Nil thus ?case by (auto simp:coeff_int_def choose_int_def)
case (Cons v xs i)
show ?case
proof (cases "xs = []")
case True
show ?thesis unfolding True
by (cases "nat i", cases "nat (i - 1)", auto simp: coeff_int_def choose_int_def)
next
case False
hence id: "length (v # xs) - 1 = Suc (length xs - 1)" by auto
have id': "choose_int (length xs) i = choose_int (Suc (length xs - 1)) i" for i
using False by (cases xs, auto)
let ?r = "(∏a←xs. [:- a, 1:])"
let ?mv = "(∏a←xs. (max 1 (cmod a)))"
let ?c1 = "real (choose_int (length xs - 1) (i - 1 - 1))"
let ?c2 = "real (choose_int (length (v # xs) - 1) i - choose_int (length xs - 1) i)"
let "?m xs n" = "choose_int (length xs - 1) n * (∏a←xs. (max 1 (cmod a)))"
have le1:"1 ≤ max 1 (cmod v)" by auto
have le2:"cmod v ≤ max 1 (cmod v)" by auto
have mv_ge_1:"1 ≤ ?mv" by (rule prod_list_ge1, auto)
obtain a b c d where abcd :
"a = real (choose_int (length xs - 1) i)"
"b = real (choose_int (length xs - 1) (i - 1))"
"c = (∏a←xs. max 1 (cmod a))"
"d = cmod v" by auto
{
have c1: "c ≥ 1" unfolding abcd by (rule mv_ge_1)
have b: "b = 0 ∨ b ≥ 1" unfolding abcd by auto
have a: "a = 0 ∨ a ≥ 1" unfolding abcd by auto
hence a0: "a ≥ 0" by auto
have acd: "a * (c * d) ≤ a * (c * max 1 d)" using a0 c1
by (simp add: mult_left_mono)
from b have "b * (c + d) ≤ b * (1 + (c * max 1 d))"
proof
assume "b ≥ 1"
hence "?thesis = (c + d ≤ 1 + c * max 1 d)" by simp
also have …
proof (cases "d ≥ 1")
case False
hence id: "max 1 d = 1" by simp
show ?thesis using False unfolding id by simp
next
case True
hence id: "max 1 d = d" by simp
show ?thesis using True c1 unfolding id by (rule sum_le_1_prod)
qed
finally show ?thesis .
qed auto
with acd have "b * c + (b * d + a * (c * d)) ≤ b + (a * (c * max 1 d) + b * (c * max 1 d))"
by (auto simp: field_simps)
} note abcd_main = this
have "cmod (coeff_int ([:- v, 1:] * ?r) i) ≤ cmod (coeff_int ?r (i - 1)) + cmod (coeff_int (smult v ?r) i)"
using norm_triangle_ineq4 by auto
also have "… ≤ ?m xs (i - 1) + (choose_int (length xs - 1) (i - 1 - 1)) + cmod (coeff_int (smult v ?r) i)"
using Cons[of "i-1"] by auto
also have "choose_int (length xs - 1) (i - 1) = choose_int (length (v # xs) - 1) i - choose_int (length xs - 1) i"
unfolding id choose_int_suc by auto
also have "?c2 * (∏a←xs. max 1 (cmod a)) + ?c1 +
cmod (coeff_int (smult v (∏a←xs. [:- a, 1:])) i) ≤
?c2 * (∏a←xs. max 1 (cmod a)) + ?c1 + cmod v * (
real (choose_int (length xs - 1) i) * (∏a←xs. max 1 (cmod a)) +
real (choose_int (length xs - 1) (i - 1)))"
using mult_mono'[OF order_refl Cons, of "cmod v" i, simplified] by (auto simp: norm_mult)
also have "… ≤ ?m (v # xs) i + (choose_int (length xs) (i - 1))" using abcd_main[unfolded abcd]
by (simp add: field_simps id')
finally show ?thesis by simp
qed
qed
lemma mignotte_helper_coeff_int': "cmod (coeff_int (∏a←lst. [:- a, 1:]) i)
≤ ((length lst - 1) choose i) * (∏a←lst. (max 1 (cmod a)))
+ min i 1 * ((length lst - 1) choose (nat (i - 1)))"
by (rule order.trans[OF mignotte_helper_coeff_int], auto simp: choose_int_def min_def)
lemma mignotte_helper_coeff:
"cmod (coeff h i) ≤ (degree h - 1 choose i) * mahler_measure_poly h
+ min i 1 * (degree h - 1 choose (i - 1)) * cmod (lead_coeff h)"
proof -
let ?r = "complex_roots_complex h"
have "cmod (coeff h i) = cmod (coeff (smult (lead_coeff h) (∏a←?r. [:- a, 1:])) i)"
unfolding complex_roots by auto
also have "… = cmod (lead_coeff h) * cmod (coeff (∏a←?r. [:- a, 1:]) i)" by(simp add:norm_mult)
also have "… ≤ cmod (lead_coeff h) * ((degree h - 1 choose i) * mahler_measure_monic h +
(min i 1 * ((degree h - 1) choose nat (int i - 1))))"
unfolding mahler_measure_monic_def
by (rule mult_left_mono, insert mignotte_helper_coeff_int'[of ?r i], auto)
also have "… = (degree h - 1 choose i) * mahler_measure_poly h + cmod (lead_coeff h) * (
min i 1 * ((degree h - 1) choose nat (int i - 1)))"
unfolding mahler_measure_poly_via_monic by (simp add: field_simps)
also have "nat (int i - 1) = i - 1" by (cases i, auto)
finally show ?thesis by (simp add: ac_simps split: if_splits)
qed
lemma mignotte_coeff_helper:
"abs (coeff h i) ≤
(degree h - 1 choose i) * mahler_measure h +
(min i 1 * (degree h - 1 choose (i - 1)) * abs (lead_coeff h))"
unfolding mahler_measure_def
using mignotte_helper_coeff[of "of_int_poly h" i]
by auto
lemma cmod_through_lead_coeff[simp]:
"cmod (lead_coeff (of_int_poly h)) = abs (lead_coeff h)"
by simp
lemma choose_approx: "n ≤ N ⟹ n choose k ≤ N choose (N div 2)"
by (rule order.trans[OF binomial_mono_left binomial_maximum])
text ‹For Mignotte's factor bound, we currently do not support queries for individual coefficients,
as we do not have a combined factor bound algorithm.›
definition mignotte_bound :: "int poly ⇒ nat ⇒ int" where
"mignotte_bound f d = (let d' = d - 1; d2 = d' div 2; binom = (d' choose d2) in
(mahler_approximation 2 binom f + binom * abs (lead_coeff f)))"
lemma mignotte_bound_main:
assumes "f ≠ 0" "g dvd f" "degree g ≤ n"
shows "¦coeff g k¦ ≤ ⌊real (n - 1 choose k) * mahler_measure f⌋ +
int (min k 1 * (n - 1 choose (k - 1))) * ¦lead_coeff f¦"
proof-
let ?bnd = 2
let ?n = "(n - 1) choose k"
let ?n' = "min k 1 * ((n - 1) choose (k - 1))"
let ?approx = "mahler_approximation ?bnd ?n f"
obtain h where gh:"g * h = f" using assms by (metis dvdE)
have nz:"g≠0" "h≠0" using gh assms(1) by auto
have g1:"(1::real) ≤ mahler_measure h" using mahler_measure_poly_ge_1 gh assms(1) by auto
note g0 = mahler_measure_ge_0
have to_n: "(degree g - 1 choose k) ≤ real ?n"
using binomial_mono_left[of "degree g - 1" "n - 1" k] assms(3) by auto
have to_n': "min k 1 * (degree g - 1 choose (k - 1)) ≤ real ?n'"
using binomial_mono_left[of "degree g - 1" "n - 1" "k - 1"] assms(3)
by (simp add: min_def)
have "¦coeff g k¦ ≤ (degree g - 1 choose k) * mahler_measure g
+ (real (min k 1 * (degree g - 1 choose (k - 1))) * ¦lead_coeff g¦)"
using mignotte_coeff_helper[of g k] by simp
also have "… ≤ ?n * mahler_measure f + real ?n' * ¦lead_coeff f¦"
proof (rule add_mono[OF mult_mono[OF to_n] mult_mono[OF to_n']])
have "mahler_measure g ≤ mahler_measure g * mahler_measure h" using g1 g0[of g]
using mahler_measure_poly_ge_1 nz(1) by force
thus "mahler_measure g ≤ mahler_measure f"
using measure_eq_prod[of "of_int_poly g" "of_int_poly h"]
unfolding mahler_measure_def gh[symmetric] by (auto simp: hom_distribs)
have *: "lead_coeff f = lead_coeff g * lead_coeff h"
unfolding arg_cong[OF gh, of lead_coeff, symmetric] by (rule lead_coeff_mult)
have "¦lead_coeff h¦ ≠ 0" using nz(2) by auto
hence lh: "¦lead_coeff h¦ ≥ 1" by linarith
have "¦lead_coeff f¦ = ¦lead_coeff g¦ * ¦lead_coeff h¦" unfolding * by (rule abs_mult)
also have "… ≥ ¦lead_coeff g¦ * 1"
by (rule mult_mono, insert lh, auto)
finally have "¦lead_coeff g¦ ≤ ¦lead_coeff f¦" by simp
thus "real_of_int ¦lead_coeff g¦ ≤ real_of_int ¦lead_coeff f¦" by simp
qed (auto simp: g0)
finally have "¦coeff g k¦ ≤ ?n * mahler_measure f + real_of_int (?n' * ¦lead_coeff f¦)" by simp
from floor_mono[OF this, folded floor_add_int]
have "¦coeff g k¦ ≤ floor (?n * mahler_measure f) + ?n' * ¦lead_coeff f¦" by linarith
thus ?thesis unfolding mignotte_bound_def Let_def using mahler_approximation[of ?n f ?bnd] by auto
qed
lemma Mignotte_bound:
shows "of_int ¦coeff g k¦ ≤ (degree g choose k) * mahler_measure g"
proof (cases "k ≤ degree g ∧ g ≠ 0")
case False
hence "coeff g k = 0" using le_degree by (cases "g = 0", auto)
thus ?thesis using mahler_measure_ge_0[of g] by auto
next
case kg: True
hence g: "g ≠ 0" "g dvd g" by auto
from mignotte_bound_main[OF g le_refl, of k]
have "real_of_int ¦coeff g k¦
≤ of_int ⌊real (degree g - 1 choose k) * mahler_measure g⌋ +
of_int (int (min k 1 * (degree g - 1 choose (k - 1))) * ¦lead_coeff g¦)" by linarith
also have "… ≤ real (degree g - 1 choose k) * mahler_measure g
+ real (min k 1 * (degree g - 1 choose (k - 1))) * (of_int ¦lead_coeff g¦ * 1)"
by (rule add_mono, force, auto)
also have "… ≤ real (degree g - 1 choose k) * mahler_measure g
+ real (min k 1 * (degree g - 1 choose (k - 1))) * mahler_measure g"
by (rule add_left_mono[OF mult_left_mono],
unfold mahler_measure_def mahler_measure_poly_def,
rule mult_mono, auto intro!: prod_list_ge1)
also have "… =
(real ((degree g - 1 choose k) + (min k 1 * (degree g - 1 choose (k - 1))))) * mahler_measure g"
by (auto simp: field_simps)
also have "(degree g - 1 choose k) + (min k 1 * (degree g - 1 choose (k - 1))) = degree g choose k"
proof (cases "k = 0")
case False
then obtain kk where k: "k = Suc kk" by (cases k, auto)
with kg obtain gg where g: "degree g = Suc gg" by (cases "degree g", auto)
show ?thesis unfolding k g by auto
qed auto
finally show ?thesis .
qed
lemma mignotte_bound:
assumes "f ≠ 0" "g dvd f" "degree g ≤ n"
shows "¦coeff g k¦ ≤ mignotte_bound f n"
proof -
let ?bnd = 2
let ?n = "(n - 1) choose ((n - 1) div 2)"
have to_n: "(n - 1 choose k) ≤ real ?n" for k
using choose_approx[OF le_refl] by auto
from mignotte_bound_main[OF assms, of k]
have "¦coeff g k¦ ≤
⌊real (n - 1 choose k) * mahler_measure f⌋ +
int (min k 1 * (n - 1 choose (k - 1))) * ¦lead_coeff f¦" .
also have "… ≤ ⌊real (n - 1 choose k) * mahler_measure f⌋ +
int ((n - 1 choose (k - 1))) * ¦lead_coeff f¦"
by (rule add_left_mono[OF mult_right_mono], cases k, auto)
also have "… ≤ mignotte_bound f n"
unfolding mignotte_bound_def Let_def
by (rule add_mono[OF order.trans[OF floor_mono[OF mult_right_mono]
mahler_approximation[of ?n f ?bnd]] mult_right_mono], insert to_n mahler_measure_ge_0, auto)
finally show ?thesis .
qed
text ‹As indicated before, at the moment the only available factor bound is Mignotte's one.
As future work one might use a combined bound.›
definition factor_bound :: "int poly ⇒ nat ⇒ int" where
"factor_bound = mignotte_bound"
lemma factor_bound: assumes "f ≠ 0" "g dvd f" "degree g ≤ n"
shows "¦coeff g k¦ ≤ factor_bound f n"
unfolding factor_bound_def by (rule mignotte_bound[OF assms])
text ‹We further prove a result for factor bounds and scalar multiplication.›
lemma factor_bound_ge_0: "f ≠ 0 ⟹ factor_bound f n ≥ 0"
using factor_bound[of f 1 n 0] by auto
lemma factor_bound_smult: assumes f: "f ≠ 0" and d: "d ≠ 0"
and dvd: "g dvd smult d f" and deg: "degree g ≤ n"
shows "¦coeff g k¦ ≤ ¦d¦ * factor_bound f n"
proof -
let ?nf = "primitive_part f" let ?cf = "content f"
let ?ng = "primitive_part g" let ?cg = "content g"
from content_dvd_contentI[OF dvd] have "?cg dvd abs d * ?cf"
unfolding content_smult_int .
hence dvd_c: "?cg dvd d * ?cf" using d
by (metis abs_content_int abs_mult dvd_abs_iff)
from primitive_part_dvd_primitive_partI[OF dvd] have "?ng dvd smult (sgn d) ?nf" unfolding primitive_part_smult_int .
hence dvd_n: "?ng dvd ?nf" using d
by (metis content_eq_zero_iff dvd dvd_smult_int f mult_eq_0_iff content_times_primitive_part smult_smult)
define gc where "gc = gcd ?cf ?cg"
define cg where "cg = ?cg div gc"
from dvd d f have g: "g ≠ 0" by auto
from f have cf: "?cf ≠ 0" by auto
from g have cg: "?cg ≠ 0" by auto
hence gc: "gc ≠ 0" unfolding gc_def by auto
have cg_dvd: "cg dvd ?cg" unfolding cg_def gc_def using g by (simp add: div_dvd_iff_mult)
have cg_id: "?cg = cg * gc" unfolding gc_def cg_def using g cf by simp
from dvd_smult_int[OF d dvd] have ngf: "?ng dvd f" .
have gcf: "¦gc¦ dvd content f" unfolding gc_def by auto
have dvd_f: "smult gc ?ng dvd f"
proof (rule dvd_content_dvd,
unfold content_smult_int content_primitive_part[OF g]
primitive_part_smult_int primitive_part_idemp)
show "¦gc¦ * 1 dvd content f" using gcf by auto
show "smult (sgn gc) (primitive_part g) dvd primitive_part f"
using dvd_n cf gc using zsgn_def by force
qed
have "cg dvd d" using dvd_c unfolding gc_def cg_def using cf cg d
by (simp add: div_dvd_iff_mult dvd_gcd_mult)
then obtain h where dcg: "d = cg * h" unfolding dvd_def by auto
with d have "h ≠ 0" by auto
hence h1: "¦h¦ ≥ 1" by simp
have "degree (smult gc (primitive_part g)) = degree g"
using gc by auto
from factor_bound[OF f dvd_f, unfolded this, OF deg, of k, unfolded coeff_smult]
have le: "¦gc * coeff ?ng k¦ ≤ factor_bound f n" .
note f0 = factor_bound_ge_0[OF f, of n]
from mult_left_mono[OF le, of "abs cg"]
have "¦cg * gc * coeff ?ng k¦ ≤ ¦cg¦ * factor_bound f n"
unfolding abs_mult[symmetric] by simp
also have "cg * gc * coeff ?ng k = coeff (smult ?cg ?ng) k" unfolding cg_id by simp
also have "… = coeff g k" unfolding content_times_primitive_part by simp
finally have "¦coeff g k¦ ≤ 1 * (¦cg¦ * factor_bound f n)" by simp
also have "… ≤ ¦h¦ * (¦cg¦ * factor_bound f n)"
by (rule mult_right_mono[OF h1], insert f0, auto)
also have "… = (¦cg * h¦) * factor_bound f n" by (simp add: abs_mult)
finally show ?thesis unfolding dcg .
qed
end
Theory Sublist_Iteration
subsection ‹Iteration of Subsets of Factors›
theory Sublist_Iteration
imports
Polynomial_Factorization.Missing_Multiset
Polynomial_Factorization.Missing_List
"HOL-Library.IArray"
begin
paragraph ‹Misc lemmas›
lemma mem_snd_map: "(∃x. (x, y) ∈ S) ⟷ y ∈ snd ` S" by force
lemma filter_upt: assumes "l ≤ m" "m < n" shows "filter ((≤) m) [l..<n] = [m..<n]"
proof(insert assms, induct n)
case 0 then show ?case by auto
next
case (Suc n) then show ?case by (cases "m = n", auto)
qed
lemma upt_append: "i < j ⟹ j < k ⟹ [i..<j]@[j..<k] = [i..<k]"
proof(induct k arbitrary: j)
case 0 then show ?case by auto
next
case (Suc k) then show ?case by (cases "j = k", auto)
qed
lemma IArray_sub[simp]: "(!!) as = (!) (IArray.list_of as)" by auto
declare IArray.sub_def[simp del]
text ‹Following lemmas in this section are for @{const subseqs}›
lemma subseqs_Cons[simp]: "subseqs (x#xs) = map (Cons x) (subseqs xs) @ subseqs xs"
by (simp add: Let_def)
declare subseqs.simps(2) [simp del]
lemma singleton_mem_set_subseqs [simp]: "[x] ∈ set (subseqs xs) ⟷ x ∈ set xs" by (induct xs, auto)
lemma Cons_mem_set_subseqsD: "y#ys ∈ set (subseqs xs) ⟹ y ∈ set xs" by (induct xs, auto)
lemma subseqs_subset: "ys ∈ set (subseqs xs) ⟹ set ys ⊆ set xs"
by (metis Pow_iff image_eqI subseqs_powset)
lemma Cons_mem_set_subseqs_Cons:
"y#ys ∈ set (subseqs (x#xs)) ⟷ (y = x ∧ ys ∈ set (subseqs xs)) ∨ y#ys ∈ set (subseqs xs)"
by auto
lemma sorted_subseqs_sorted:
"sorted xs ⟹ ys ∈ set (subseqs xs) ⟹ sorted ys"
proof(induct xs arbitrary: ys)
case Nil thus ?case by simp
next
case Cons thus ?case using subseqs_subset by fastforce
qed
lemma subseqs_of_subseq: "ys ∈ set (subseqs xs) ⟹ set (subseqs ys) ⊆ set (subseqs xs)"
proof(induct xs arbitrary: ys)
case Nil then show ?case by auto
next
case IHx: (Cons x xs)
from IHx.prems show ?case
proof(induct ys)
case Nil then show ?case by auto
next
case IHy: (Cons y ys)
from IHy.prems[unfolded subseqs_Cons]
consider "y = x" "ys ∈ set (subseqs xs)" | "y # ys ∈ set (subseqs xs)" by auto
then show ?case
proof(cases)
case 1 with IHx.hyps show ?thesis by auto
next
case 2 from IHx.hyps[OF this] show ?thesis by auto
qed
qed
qed
lemma mem_set_subseqs_append: "xs ∈ set (subseqs ys) ⟹ xs ∈ set (subseqs (zs @ ys))"
by (induct zs, auto)
lemma Cons_mem_set_subseqs_append:
"x ∈ set ys ⟹ xs ∈ set (subseqs zs) ⟹ x#xs ∈ set (subseqs (ys@zs))"
proof(induct ys)
case Nil then show ?case by auto
next
case IH: (Cons y ys)
then consider "x = y" | "x ∈ set ys" by auto
then show ?case
proof(cases)
case 1 with IH show ?thesis by (auto intro: mem_set_subseqs_append)
next
case 2 from IH.hyps[OF this IH.prems(2)] show ?thesis by auto
qed
qed
lemma Cons_mem_set_subseqs_sorted:
"sorted xs ⟹ y#ys ∈ set (subseqs xs) ⟹ y#ys ∈ set (subseqs (filter (λx. y ≤ x) xs))"
by (induct xs) (auto simp: Let_def)
lemma subseqs_map[simp]: "subseqs (map f xs) = map (map f) (subseqs xs)" by (induct xs, auto)
lemma subseqs_of_indices: "map (map (nth xs)) (subseqs [0..<length xs]) = subseqs xs"
proof (induct xs)
case Nil then show ?case by auto
next
case (Cons x xs)
from this[symmetric]
have "subseqs xs = map (map ((!) (x#xs))) (subseqs [Suc 0..<Suc (length xs)])"
by (fold map_Suc_upt, simp)
then show ?case by (unfold length_Cons upt_conv_Cons[OF zero_less_Suc], simp)
qed
paragraph ‹Specification›
definition "subseq_of_length n xs ys ≡ ys ∈ set (subseqs xs) ∧ length ys = n"
lemma subseq_of_lengthI[intro]:
assumes "ys ∈ set (subseqs xs)" "length ys = n"
shows "subseq_of_length n xs ys"
by (insert assms, unfold subseq_of_length_def, auto)
lemma subseq_of_lengthD[dest]:
assumes "subseq_of_length n xs ys"
shows "ys ∈ set (subseqs xs)" "length ys = n"
by (insert assms, unfold subseq_of_length_def, auto)
lemma subseq_of_length0[simp]: "subseq_of_length 0 xs ys ⟷ ys = []" by auto
lemma subseq_of_length_Nil[simp]: "subseq_of_length n [] ys ⟷ n = 0 ∧ ys = []"
by (auto simp: subseq_of_length_def)
lemma subseq_of_length_Suc_upt:
"subseq_of_length (Suc n) [0..<m] xs ⟷
(if n = 0 then length xs = Suc 0 ∧ hd xs < m
else hd xs < hd (tl xs) ∧ subseq_of_length n [0..<m] (tl xs))" (is "?l ⟷ ?r")
proof(cases "n")
case 0
show ?thesis
proof(intro iffI)
assume l: "?l"
with 0 have 1: "length xs = Suc 0" by auto
then have xs: "xs = [hd xs]" by (metis length_0_conv length_Suc_conv list.sel(1))
with l have "[hd xs] ∈ set (subseqs [0..<m])" by auto
with 1 show "?r" by (unfold 0, auto)
next
assume ?r
with 0 have 1: "length xs = Suc 0" and 2: "hd xs < m" by auto
then have xs: "xs = [hd xs]" by (metis length_0_conv length_Suc_conv list.sel(1))
from 2 show "?l" by (subst xs, auto simp: 0)
qed
next
case n: (Suc n')
show ?thesis
proof (intro iffI)
assume "?l"
with n have 1: "length xs = Suc (Suc n')" and 2: "xs ∈ set (subseqs [0..<m])" by auto
from 1[unfolded length_Suc_conv]
obtain x y ys where xs: "xs = x#y#ys" and n': "length ys = n'" by auto
have "sorted xs" by(rule sorted_subseqs_sorted[OF _ 2], auto)
from this[unfolded xs] have "x ≤ y" by auto
moreover
from 2 have "distinct xs" by (rule subseqs_distinctD, auto)
from this[unfolded xs] have "x ≠ y" by auto
ultimately have "x < y" by auto
moreover
from 2 have "y#ys ∈ set (subseqs [0..<m])" by (unfold xs, auto dest: Cons_in_subseqsD)
with n n' have "subseq_of_length n [0..<m] (y#ys)" by auto
ultimately show ?r by (auto simp: xs)
next
assume r: "?r"
with n have len: "length xs = Suc (Suc n')"
and *: "hd xs < hd (tl xs)" "tl xs ∈ set (subseqs [0..<m])" by auto
from len[unfolded length_Suc_conv] obtain x y ys
where xs: "xs = x#y#ys" and n': "length ys = n'" by auto
with * have xy: "x < y" and yys: "y#ys ∈ set (subseqs [0..<m])" by auto
from Cons_mem_set_subseqs_sorted[OF _ yys]
have "y#ys ∈ set (subseqs (filter ((≤) y) [0..<m]))" by auto
also from Cons_mem_set_subseqsD[OF yys] have ym: "y < m" by auto
then have "filter ((≤) y) [0..<m] = [y..<m]" by (auto intro: filter_upt)
finally have "y#ys ∈ set (subseqs [y..<m])" by auto
with xy have "x#y#ys ∈ set (subseqs (x#[y..<m]))" by auto
also from xy have "... ⊆ set (subseqs ([0..<y] @ [y..<m]))"
by (intro subseqs_of_subseq Cons_mem_set_subseqs_append, auto intro: subseqs_refl)
also from xy ym have "[0..<y] @ [y..<m] = [0..<m]" by (auto intro: upt_append)
finally have "xs ∈ set (subseqs [0..<m])" by (unfold xs)
with len[folded n] show ?l by auto
qed
qed
lemma subseqs_of_length_of_indices:
"{ ys. subseq_of_length n xs ys } = { map (nth xs) is | is. subseq_of_length n [0..<length xs] is }"
by(unfold subseq_of_length_def, subst subseqs_of_indices[symmetric], auto)
lemma subseqs_of_length_Suc_Cons:
"{ ys. subseq_of_length (Suc n) (x#xs) ys } =
Cons x ` { ys. subseq_of_length n xs ys } ∪ { ys. subseq_of_length (Suc n) xs ys }"
by (unfold subseq_of_length_def, auto)
datatype ('a,'b,'state)subseqs_impl = Sublists_Impl
(create_subseqs: "'b ⇒ 'a list ⇒ nat ⇒ ('b × 'a list)list × 'state")
(next_subseqs: "'state ⇒ ('b × 'a list)list × 'state")
locale subseqs_impl =
fixes f :: "'a ⇒ 'b ⇒ 'b"
and sl_impl :: "('a,'b,'state)subseqs_impl"
begin
definition S :: "'b ⇒ 'a list ⇒ nat ⇒ ('b × 'a list)set" where
"S base elements n = { (foldr f ys base, ys) | ys. subseq_of_length n elements ys }"
end
locale correct_subseqs_impl = subseqs_impl f sl_impl
for f :: "'a ⇒ 'b ⇒ 'b"
and sl_impl :: "('a,'b,'state)subseqs_impl" +
fixes invariant :: "'b ⇒ 'a list ⇒ nat ⇒ 'state ⇒ bool"
assumes create_subseqs: "create_subseqs sl_impl base elements n = (out, state) ⟹ invariant base elements n state ∧ set out = S base elements n"
and next_subseqs:
"invariant base elements n state ⟹
next_subseqs sl_impl state = (out, state') ⟹
invariant base elements (Suc n) state' ∧ set out = S base elements (Suc n)"
paragraph ‹Basic Implementation›
fun subseqs_i_n_main :: "('a ⇒ 'b ⇒ 'b) ⇒ 'b ⇒ 'a list ⇒ nat ⇒ nat ⇒ ('b × 'a list) list" where
"subseqs_i_n_main f b xs i n = (if i = 0 then [(b,[])] else if i = n then [(foldr f xs b, xs)]
else case xs of
(y # ys) ⇒ map (λ (c,zs) ⇒ (c,y # zs)) (subseqs_i_n_main f (f y b) ys (i - 1) (n - 1))
@ subseqs_i_n_main f b ys i (n - 1))"
declare subseqs_i_n_main.simps[simp del]
definition subseqs_length :: "('a ⇒ 'b ⇒ 'b) ⇒ 'b ⇒ nat ⇒ 'a list ⇒ ('b × 'a list) list" where
"subseqs_length f b i xs = (
let n = length xs in if i > n then [] else subseqs_i_n_main f b xs i n)"
lemma subseqs_length: assumes f_ac: "⋀ x y z. f x (f y z) = f y (f x z)"
shows "set (subseqs_length f a n xs) =
{ (foldr f ys a, ys) | ys. ys ∈ set (subseqs xs) ∧ length ys = n}"
proof -
show ?thesis
proof (cases "length xs < n")
case True
thus ?thesis unfolding subseqs_length_def Let_def
using length_subseqs[of xs] subseqs_length_simple_False by auto
next
case False
hence id: "(length xs < n) = False" and "n ≤ length xs" by auto
from this(2) show ?thesis unfolding subseqs_length_def Let_def id if_False
proof (induct xs arbitrary: n a rule: length_induct[rule_format])
case (1 xs n a)
note n = 1(2)
note IH = 1(1)
note simp[simp] = subseqs_i_n_main.simps[of f _ xs n]
show ?case
proof (cases "n = 0")
case True
thus ?thesis unfolding simp by simp
next
case False note 0 = this
show ?thesis
proof (cases "n = length xs")
case True
have "?thesis = ({(foldr f xs a, xs)} = (λ ys. (foldr f ys a, ys)) ` {ys. ys ∈ set (subseqs xs) ∧ length ys = length xs})"
unfolding simp using 0 True by auto
from this[unfolded full_list_subseqs] show ?thesis by auto
next
case False
with n have n: "n < length xs" by auto
from 0 obtain m where m: "n = Suc m" by (cases n, auto)
from n 0 obtain y ys where xs: "xs = y # ys" by (cases xs, auto)
from n m xs have le: "m ≤ length ys" "n ≤ length ys" by auto
from xs have lt: "length ys < length xs" by auto
have sub: "set (subseqs_i_n_main f a xs n (length xs)) =
(λ(c, zs). (c, y # zs)) ` set (subseqs_i_n_main f (f y a) ys m (length ys)) ∪
set (subseqs_i_n_main f a ys n (length ys))"
unfolding simp using 0 False by (simp add: xs m)
have fold: "⋀ ys. foldr f ys (f y a) = f y (foldr f ys a)"
by (induct_tac ys, auto simp: f_ac)
show ?thesis unfolding sub IH[OF lt le(1)] IH[OF lt le(2)]
unfolding m xs by (auto simp: Let_def fold)
qed
qed
qed
qed
qed
definition basic_subseqs_impl :: "('a ⇒ 'b ⇒ 'b) ⇒ ('a, 'b, 'b × 'a list × nat)subseqs_impl" where
"basic_subseqs_impl f = Sublists_Impl
(λ a xs n. (subseqs_length f a n xs, (a,xs,n)))
(λ (a,xs,n). (subseqs_length f a (Suc n) xs, (a,xs,Suc n)))"
lemma basic_subseqs_impl: assumes f_ac: "⋀ x y z. f x (f y z) = f y (f x z)"
shows "correct_subseqs_impl f (basic_subseqs_impl f)
(λ a xs n triple. (a,xs,n) = triple)"
by (unfold_locales; unfold subseqs_impl.S_def basic_subseqs_impl_def subseq_of_length_def,
insert subseqs_length[of f, OF f_ac], auto)
paragraph ‹Improved Implementation›
datatype ('a,'b,'state) subseqs_foldr_impl = Sublists_Foldr_Impl
(subseqs_foldr: "'b ⇒ 'a list ⇒ nat ⇒ 'b list × 'state")
(next_subseqs_foldr: "'state ⇒ 'b list × 'state")
locale subseqs_foldr_impl =
fixes f :: "'a ⇒ 'b ⇒ 'b"
and impl :: "('a,'b,'state) subseqs_foldr_impl"
begin
definition S where "S base elements n ≡ { foldr f ys base | ys. subseq_of_length n elements ys }"
end
locale correct_subseqs_foldr_impl = subseqs_foldr_impl f impl
for f and impl :: "('a,'b,'state) subseqs_foldr_impl" +
fixes invariant :: "'b ⇒ 'a list ⇒ nat ⇒ 'state ⇒ bool"
assumes subseqs_foldr:
"subseqs_foldr impl base elements n = (out, state) ⟹
invariant base elements n state ∧ set out = S base elements n"
and next_subseqs_foldr:
"next_subseqs_foldr impl state = (out, state') ⟹ invariant base elements n state ⟹
invariant base elements (Suc n) state' ∧ set out = S base elements (Suc n)"
locale my_subseqs =
fixes f :: "'a ⇒ 'b ⇒ 'b"
begin
context fixes head :: "'a" and tail :: "'a iarray"
begin
fun next_subseqs1 and next_subseqs2
where "next_subseqs1 ret0 ret1 [] = (ret0, (head, tail, ret1))"
| "next_subseqs1 ret0 ret1 ((i,v)#prevs) = next_subseqs2 (f head v # ret0) ret1 prevs v [0..<i]"
| "next_subseqs2 ret0 ret1 prevs v [] = next_subseqs1 ret0 ret1 prevs"
| "next_subseqs2 ret0 ret1 prevs v (j#js) =
(let v' = f (tail !! j) v in next_subseqs2 (v' # ret0) ((j,v') # ret1) prevs v js)"
definition "next_subseqs2_set v js ≡ { (j, f (tail !! j) v) | j. j ∈ set js }"
definition "out_subseqs2_set v js ≡ { f (tail !! j) v | j. j ∈ set js }"
definition "next_subseqs1_set prevs ≡ ⋃ { next_subseqs2_set v [0..<i] | v i. (i,v) ∈ set prevs }"
definition "out_subseqs1_set prevs ≡
(f head ∘ snd) ` set prevs ∪ (⋃ { out_subseqs2_set v [0..<i] | v i. (i,v) ∈ set prevs })"
fun next_subseqs1_spec where
"next_subseqs1_spec out nexts prevs (out', (head',tail',nexts')) ⟷
set nexts' = set nexts ∪ next_subseqs1_set prevs ∧
set out' = set out ∪ out_subseqs1_set prevs"
fun next_subseqs2_spec where
"next_subseqs2_spec out nexts prevs v js (out', (head',tail',nexts')) ⟷
set nexts' = set nexts ∪ next_subseqs1_set prevs ∪ next_subseqs2_set v js ∧
set out' = set out ∪ out_subseqs1_set prevs ∪ out_subseqs2_set v js"
lemma next_subseqs2_Cons:
"next_subseqs2_set v (j#js) = insert (j, f (tail!!j) v) (next_subseqs2_set v js)"
by (auto simp: next_subseqs2_set_def)
lemma out_subseqs2_Cons:
"out_subseqs2_set v (j#js) = insert (f (tail!!j) v) (out_subseqs2_set v js)"
by (auto simp: out_subseqs2_set_def)
lemma next_subseqs1_set_as_next_subseqs2_set:
"next_subseqs1_set ((i,v) # prevs) = next_subseqs1_set prevs ∪ next_subseqs2_set v [0..<i]"
by (auto simp: next_subseqs1_set_def)
lemma out_subseqs1_set_as_out_subseqs2_set:
"out_subseqs1_set ((i,v) # prevs) =
{ f head v } ∪ out_subseqs1_set prevs ∪ out_subseqs2_set v [0..<i]"
by (auto simp: out_subseqs1_set_def)
lemma next_subseqs1_spec:
shows "⋀out nexts. next_subseqs1_spec out nexts prevs (next_subseqs1 out nexts prevs)"
and "⋀out nexts. next_subseqs2_spec out nexts prevs v js (next_subseqs2 out nexts prevs v js)"
proof(induct rule: next_subseqs1_next_subseqs2.induct)
case (1 ret0 ret1)
then show ?case by (simp add: next_subseqs1_set_def out_subseqs1_set_def)
next
case (2 ret0 ret1 i v prevs)
show ?case
proof(cases "next_subseqs1 out nexts ((i, v) # prevs)")
case split: (fields out' head' tail' nexts')
have "next_subseqs2_spec (f head v # out) nexts prevs v [0..<i] (out', (head',tail',nexts'))"
by (fold split, unfold next_subseqs1.simps, rule 2)
then show ?thesis
apply (unfold next_subseqs2_spec.simps split)
by (auto simp: next_subseqs1_set_as_next_subseqs2_set out_subseqs1_set_as_out_subseqs2_set)
qed
next
case (3 ret0 ret1 prevs v)
show ?case
proof (cases "next_subseqs1 out nexts prevs")
case split: (fields out' head' tail' nexts')
from 3[of out nexts] show ?thesis by(simp add: split next_subseqs2_set_def out_subseqs2_set_def)
qed
next
case (4 ret0 ret1 prevs v j js)
define tj where "tj = tail !! j"
define nexts'' where "nexts'' = (j, f tj v) # nexts"
define out'' where "out'' = (f tj v) # out"
let ?n = "next_subseqs2 out'' nexts'' prevs v js"
show ?case
proof (cases ?n)
case split: (fields out' head' tail' nexts')
show ?thesis
apply (unfold next_subseqs2.simps Let_def)
apply (fold tj_def)
apply (fold out''_def nexts''_def)
apply (unfold split next_subseqs2_spec.simps next_subseqs2_Cons out_subseqs2_Cons)
using 4[OF refl, of out'' nexts'', unfolded split]
apply (auto simp: tj_def nexts''_def out''_def)
done
qed
qed
end
fun next_subseqs where "next_subseqs (head,tail,prevs) = next_subseqs1 head tail [] [] prevs"
fun create_subseqs
where "create_subseqs base elements 0 = (
if elements = [] then ([base],(undefined, IArray [], []))
else let head = hd elements; tail = IArray (tl elements) in
([base], (head, tail, [(IArray.length tail, base)])))"
| "create_subseqs base elements (Suc n) =
next_subseqs (snd (create_subseqs base elements n))"
definition impl where "impl = Sublists_Foldr_Impl create_subseqs next_subseqs"
sublocale subseqs_foldr_impl f impl .
definition set_prevs where "set_prevs base tail n ≡
{ (i, foldr f (map ((!) tail) is) base) | i is.
subseq_of_length n [0..<length tail] is ∧ i = (if n = 0 then length tail else hd is) }"
lemma snd_set_prevs:
"snd ` (set_prevs base tail n) = (λas. foldr f as base) ` { as. subseq_of_length n tail as }"
by (subst subseqs_of_length_of_indices, auto simp: set_prevs_def image_Collect)
fun invariant where "invariant base elements n (head,tail,prevs) =
(if elements = [] then prevs = []
else head = hd elements ∧ tail = IArray (tl elements) ∧ set prevs = set_prevs base (tl elements) n)"
lemma next_subseq_preserve:
assumes "next_subseqs (head,tail,prevs) = (out, (head',tail',prevs'))"
shows "head' = head" "tail' = tail"
proof-
define P :: "'b list × _ × _ × (nat × 'b) list ⇒ bool"
where "P ≡ λ (out, (head',tail',prevs')). head' = head ∧ tail' = tail"
{ fix ret0 ret1 v js
have *: "P (next_subseqs1 head tail ret0 ret1 prevs)"
and "P (next_subseqs2 head tail ret0 ret1 prevs v js)"
by(induct rule: next_subseqs1_next_subseqs2.induct, simp add: P_def, auto simp: Let_def)
}
from this(1)[unfolded P_def, of "[]" "[]", folded next_subseqs.simps] assms
show "head' = head" "tail' = tail" by auto
qed
lemma next_subseqs_spec:
assumes nxt: "next_subseqs (head,tail,prevs) = (out, (head',tail',prevs'))"
shows "set prevs' = { (j, f (tail !! j) v) | v i j. (i,v) ∈ set prevs ∧ j < i }" (is "?g1")
and "set out = (f head ∘ snd) ` set prevs ∪ snd ` set prevs'" (is "?g2")
proof-
note next_subseqs1_spec(1)[of head tail Nil Nil prevs]
note this[unfolded nxt[simplified]]
note this[unfolded next_subseqs1_spec.simps]
note this[unfolded next_subseqs1_set_def out_subseqs1_set_def]
note * = this[unfolded next_subseqs2_set_def out_subseqs2_set_def]
then show g1: ?g1 by auto
also have "snd ` ... = (⋃ {{(f (tail !! j) v) | j. j < i} | v i. (i, v) ∈ set prevs})"
by (unfold image_Collect, auto)
finally have **: "snd ` set prevs' = ...".
with conjunct2[OF *] show ?g2 by simp
qed
lemma next_subseq_prevs:
assumes nxt: "next_subseqs (head,tail,prevs) = (out, (head',tail',prevs'))"
and inv_prevs: "set prevs = set_prevs base (IArray.list_of tail) n"
shows "set prevs' = set_prevs base (IArray.list_of tail) (Suc n)" (is "?l = ?r")
proof(intro equalityI subsetI)
fix t
assume r: "t ∈ ?r"
from this[unfolded set_prevs_def] obtain iis
where t: "t = (hd iis, foldr f (map ((!!) tail) iis) base)"
and sl: "subseq_of_length (Suc n) [0..<IArray.length tail] iis" by auto
from sl have "length iis > 0" by auto
then obtain i "is" where iis: "iis = i#is" by (meson list.set_cases nth_mem)
define v where "v = foldr f (map ((!!) tail) is) base"
note sl[unfolded subseq_of_length_Suc_upt]
note nxt = next_subseqs_spec[OF nxt]
show "t ∈ ?l"
proof(cases "n = 0")
case True
from sl[unfolded subseq_of_length_Suc_upt] t
show ?thesis by (unfold nxt[unfolded inv_prevs] True set_prevs_def length_Suc_conv, auto)
next
case [simp]: False
from sl[unfolded subseq_of_length_Suc_upt iis,simplified]
have i: "i < hd is" and "is": "subseq_of_length n [0..<IArray.length tail] is" by auto
then have *: "(hd is, v) ∈ set_prevs base (IArray.list_of tail) n"
by (unfold set_prevs_def, auto intro!: exI[of _ "is"] simp: v_def)
with i have "(i, f (tail !! i) v) ∈ {(j, f (tail !! j) v) | j. j < hd is}" by auto
with t[unfolded iis] have "t ∈ ..." by (auto simp: v_def)
with * show ?thesis by (unfold nxt[unfolded inv_prevs], auto)
qed
next
fix t
assume l: "t ∈ ?l"
from l[unfolded next_subseqs_spec(1)[OF nxt]]
obtain j v i
where t: "t = (j, f (tail!!j) v)"
and j: "j < i"
and iv: "(i,v) ∈ set prevs" by auto
from iv[unfolded inv_prevs set_prevs_def, simplified]
obtain "is"
where v: "v = foldr f (map ((!!) tail) is) base"
and "is": "subseq_of_length n [0..<IArray.length tail] is"
and i: "if n = 0 then i = IArray.length tail else i = hd is" by auto
from "is" j i have jis: "subseq_of_length (Suc n) [0..<IArray.length tail] (j#is)"
by (unfold subseq_of_length_Suc_upt, auto)
then show "t ∈ ?r" by (auto intro!: exI[of _ "j#is"] simp: set_prevs_def t v)
qed
lemma invariant_next_subseqs:
assumes inv: "invariant base elements n state"
and nxt: "next_subseqs state = (out, state')"
shows "invariant base elements (Suc n) state'"
proof(cases "elements = []")
case True with inv nxt show ?thesis by(cases state, auto)
next
case False with inv nxt show ?thesis
proof (cases state)
case state: (fields head tail prevs)
note inv = inv[unfolded state]
show ?thesis
proof (cases state')
case state': (fields head' tail' prevs')
note nxt = nxt[unfolded state state']
note [simp] = next_subseq_preserve[OF nxt]
from False inv
have "set prevs = set_prevs base (IArray.list_of tail) n" by auto
from False next_subseq_prevs[OF nxt this] inv
show ?thesis by(auto simp: state')
qed
qed
qed
lemma out_next_subseqs:
assumes inv: "invariant base elements n state"
and nxt: "next_subseqs state = (out, state')"
shows "set out = S base elements (Suc n)"
proof (cases state)
case state: (fields head tail prevs)
show ?thesis
proof(cases "elements = []")
case True
with inv nxt show ?thesis by (auto simp: state S_def)
next
case elements: False
show ?thesis
proof(cases state')
case state': (fields head' tail' prevs')
from elements inv[unfolded state,simplified]
have "head = hd elements"
and "tail = IArray (tl elements)"
and prevs: "set prevs = set_prevs base (tl elements) n" by auto
with elements have elements2: "elements = head # IArray.list_of tail" by auto
let ?f = "λas. (foldr f as base)"
have "set out = ?f ` {ys. subseq_of_length (Suc n) elements ys}"
proof-
from invariant_next_subseqs[OF inv nxt, unfolded state' invariant.simps if_not_P[OF elements]]
have tail': "tail' = IArray (tl elements)"
and prevs': "set prevs' = set_prevs base (tl elements) (Suc n)" by auto
note next_subseqs_spec(2)[OF nxt[unfolded state state'], unfolded this]
note this[folded image_comp, unfolded snd_set_prevs]
also note prevs
also note snd_set_prevs
also have "f head ` ?f ` { as. subseq_of_length n (tl elements) as } =
?f ` Cons head ` { as. subseq_of_length n (tl elements) as }" by (auto simp: image_def)
also note image_Un[symmetric]
also have
"((#) head ` {as. subseq_of_length n (tl elements) as} ∪
{as. subseq_of_length (Suc n) (tl elements) as}) =
{as. subseq_of_length (Suc n) elements as}"
by (unfold subseqs_of_length_Suc_Cons elements2, auto)
finally show ?thesis.
qed
then show ?thesis by (auto simp: S_def)
qed
qed
qed
lemma create_subseqs:
"create_subseqs base elements n = (out, state) ⟹
invariant base elements n state ∧ set out = S base elements n"
proof(induct n arbitrary: out state)
case 0 then show ?case by (cases "elements", cases state, auto simp: S_def Let_def set_prevs_def)
next
case (Suc n) show ?case
proof (cases "create_subseqs base elements n")
case 1: (fields out'' head tail prevs)
show ?thesis
proof (cases "next_subseqs (head, tail, prevs)")
case (fields out' head' tail' prevs')
note 2 = this[unfolded next_subseq_preserve[OF this]]
from Suc(2)[unfolded create_subseqs.simps 1 snd_conv 2]
have 3: "out' = out" "state = (head,tail,prevs')" by auto
from Suc(1)[OF 1]
have inv: "invariant base elements n (head, tail, prevs)" by auto
from out_next_subseqs[OF inv 2] invariant_next_subseqs[OF inv 2]
show ?thesis by (auto simp: 3)
qed
qed
qed
sublocale correct_subseqs_foldr_impl f impl invariant
by (unfold_locales; auto simp: impl_def invariant_next_subseqs out_next_subseqs create_subseqs)
lemma impl_correct: "correct_subseqs_foldr_impl f impl invariant" ..
end
lemmas [code] =
my_subseqs.next_subseqs.simps
my_subseqs.next_subseqs1.simps
my_subseqs.next_subseqs2.simps
my_subseqs.create_subseqs.simps
my_subseqs.impl_def
end
Theory Reconstruction
subsection ‹Reconstruction of Integer Factorization›
text ‹We implemented Zassenhaus reconstruction-algorithm, i.e., given a factorization of $f$ mod $p^n$,
the aim is to reconstruct a factorization of $f$ over the integers.›
theory Reconstruction
imports
Berlekamp_Hensel
Polynomial_Factorization.Gauss_Lemma
Polynomial_Factorization.Dvd_Int_Poly
Polynomial_Factorization.Gcd_Rat_Poly
Degree_Bound
Factor_Bound
Sublist_Iteration
Poly_Mod
begin
hide_const coeff monom
paragraph ‹Misc lemmas›
lemma foldr_of_Cons[simp]: "foldr Cons xs ys = xs @ ys" by (induct xs, auto)
lemma foldr_map_prod[simp]:
"foldr (λx. map_prod (f x) (g x)) xs base = (foldr f xs (fst base), foldr g xs (snd base))"
by (induct xs, auto)
paragraph ‹The main part›
context poly_mod
begin
definition inv_Mp :: "int poly ⇒ int poly" where
"inv_Mp = map_poly inv_M"
definition mul_const :: "int poly ⇒ int ⇒ int" where
"mul_const p c = (coeff p 0 * c) mod m"
fun prod_list_m :: "int poly list ⇒ int poly" where
"prod_list_m (f # fs) = Mp (f * prod_list_m fs)"
| "prod_list_m [] = 1"
context
fixes sl_impl :: "(int poly, int × int poly list, 'state)subseqs_foldr_impl"
and m2 :: "int"
begin
definition inv_M2 :: "int ⇒ int" where
"inv_M2 = (λ x. if x ≤ m2 then x else x - m)"
definition inv_Mp2 :: "int poly ⇒ int poly" where
"inv_Mp2 = map_poly inv_M2"
partial_function (tailrec) reconstruction :: "'state ⇒ int poly ⇒ int poly
⇒ int ⇒ nat ⇒ nat ⇒ int poly list ⇒ int poly list
⇒ (int × (int poly list)) list ⇒ int poly list" where
"reconstruction state u luu lu d r vs res cands = (case cands of Nil
⇒ let d' = Suc d
in if d' + d' > r then (u # res) else
(case next_subseqs_foldr sl_impl state of (cands,state') ⇒
reconstruction state' u luu lu d' r vs res cands)
| (lv',ws) # cands' ⇒ let
lv = inv_M2 lv'
in if lv dvd coeff luu 0 then let
vb = inv_Mp2 (Mp (smult lu (prod_list_m ws)))
in if vb dvd luu then
let pp_vb = primitive_part vb;
u' = u div pp_vb;
r' = r - length ws;
res' = pp_vb # res
in if d + d > r'
then u' # res'
else let
lu' = lead_coeff u';
vs' = fold remove1 ws vs;
(cands'', state') = subseqs_foldr sl_impl (lu',[]) vs' d
in reconstruction state' u' (smult lu' u') lu' d r' vs' res' cands''
else reconstruction state u luu lu d r vs res cands'
else reconstruction state u luu lu d r vs res cands')"
end
end
declare poly_mod.reconstruction.simps[code]
declare poly_mod.prod_list_m.simps[code]
declare poly_mod.mul_const_def[code]
declare poly_mod.inv_M2_def[code]
declare poly_mod.inv_Mp2_def[code_unfold]
declare poly_mod.inv_Mp_def[code_unfold]
definition zassenhaus_reconstruction_generic ::
"(int poly, int × int poly list, 'state) subseqs_foldr_impl
⇒ int poly list ⇒ int ⇒ nat ⇒ int poly ⇒ int poly list" where
"zassenhaus_reconstruction_generic sl_impl vs p n f = (let
lf = lead_coeff f;
pn = p^n;
(_, state) = subseqs_foldr sl_impl (lf,[]) vs 0
in
poly_mod.reconstruction pn sl_impl (pn div 2) state f (smult lf f) lf 0 (length vs) vs [] [])"
lemma coeff_mult_0: "coeff (f * g) 0 = coeff f 0 * coeff g 0"
by (metis poly_0_coeff_0 poly_mult)
lemma lead_coeff_factor: assumes u: "u = v * (w :: 'a ::idom poly)"
shows "smult (lead_coeff u) u = (smult (lead_coeff w) v) * (smult (lead_coeff v) w)"
"lead_coeff (smult (lead_coeff w) v) = lead_coeff u" "lead_coeff (smult (lead_coeff v) w) = lead_coeff u"
unfolding u by (auto simp: lead_coeff_mult lead_coeff_smult)
lemma not_irreducible⇩d_lead_coeff_factors: assumes "¬ irreducible⇩d (u :: 'a :: idom poly)" "degree u ≠ 0"
shows "∃ f g. smult (lead_coeff u) u = f * g ∧ lead_coeff f = lead_coeff u ∧ lead_coeff g = lead_coeff u
∧ degree f < degree u ∧ degree g < degree u"
proof -
from assms[unfolded irreducible⇩d_def, simplified]
obtain v w where deg: "degree v < degree u" "degree w < degree u" and u: "u = v * w" by auto
define f where "f = smult (lead_coeff w) v"
define g where "g = smult (lead_coeff v) w"
note lf = lead_coeff_factor[OF u, folded f_def g_def]
show ?thesis
proof (intro exI conjI, (rule lf)+)
show "degree f < degree u" "degree g < degree u" unfolding f_def g_def using deg u by auto
qed
qed
lemma mset_subseqs_size: "mset ` {ys. ys ∈ set (subseqs xs) ∧ length ys = n} =
{ws. ws ⊆# mset xs ∧ size ws = n}"
proof (induct xs arbitrary: n)
case (Cons x xs n)
show ?case (is "?l = ?r")
proof (cases n)
case 0
thus ?thesis by (auto simp: Let_def)
next
case (Suc m)
have "?r = {ws. ws ⊆# mset (x # xs)} ∩ {ps. size ps = n}" by auto
also have "{ws. ws ⊆# mset (x # xs)} = {ps. ps ⊆# mset xs} ∪ ((λ ps. ps + {#x#}) ` {ps. ps ⊆# mset xs})"
by (simp add: multiset_subset_insert)
also have "… ∩ {ps. size ps = n} = {ps. ps ⊆# mset xs ∧ size ps = n}
∪ ((λ ps. ps + {#x#}) ` {ps. ps ⊆# mset xs ∧ size ps = m})" unfolding Suc by auto
finally have id: "?r =
{ps. ps ⊆# mset xs ∧ size ps = n} ∪ (λps. ps + {#x#}) ` {ps. ps ⊆# mset xs ∧ size ps = m}" .
have "?l = mset ` {ys ∈ set (subseqs xs). length ys = Suc m}
∪ mset ` {ys ∈ (#) x ` set (subseqs xs). length ys = Suc m}"
unfolding Suc by (auto simp: Let_def)
also have "mset ` {ys ∈ (#) x ` set (subseqs xs). length ys = Suc m}
= (λps. ps + {#x#}) ` mset ` {ys ∈ set (subseqs xs). length ys = m}" by force
finally have id': "?l = mset ` {ys ∈ set (subseqs xs). length ys = Suc m} ∪
(λps. ps + {#x#}) ` mset ` {ys ∈ set (subseqs xs). length ys = m}" .
show ?thesis unfolding id id' Cons[symmetric] unfolding Suc by simp
qed
qed auto
context poly_mod_2
begin
lemma prod_list_m[simp]: "prod_list_m fs = Mp (prod_list fs)"
by (induct fs, auto)
lemma inv_Mp_coeff: "coeff (inv_Mp f) n = inv_M (coeff f n)"
unfolding inv_Mp_def
by (rule coeff_map_poly, insert m1, auto simp: inv_M_def)
lemma Mp_inv_Mp_id[simp]: "Mp (inv_Mp f) = Mp f"
unfolding poly_eq_iff Mp_coeff inv_Mp_coeff by simp
lemma inv_Mp_rev: assumes bnd: "⋀ n. 2 * abs (coeff f n) < m"
shows "inv_Mp (Mp f) = f"
proof (rule poly_eqI)
fix n
define c where "c = coeff f n"
from bnd[of n, folded c_def] have bnd: "2 * abs c < m" by auto
show "coeff (inv_Mp (Mp f)) n = coeff f n" unfolding inv_Mp_coeff Mp_coeff c_def[symmetric]
using inv_M_rev[OF bnd] .
qed
lemma mul_const_commute_below: "mul_const x (mul_const y z) = mul_const y (mul_const x z)"
unfolding mul_const_def by (metis mod_mult_right_eq mult.left_commute)
context
fixes p n
and sl_impl :: "(int poly, int × int poly list, 'state)subseqs_foldr_impl"
and sli :: "int × int poly list ⇒ int poly list ⇒ nat ⇒ 'state ⇒ bool"
assumes prime: "prime p"
and m: "m = p^n"
and n: "n ≠ 0"
and sl_impl: "correct_subseqs_foldr_impl (λx. map_prod (mul_const x) (Cons x)) sl_impl sli"
begin
private definition "test_dvd_exec lu u ws = (¬ inv_Mp (Mp (smult lu (prod_mset ws))) dvd smult lu u)"
private definition "test_dvd u ws = (∀ v l. v dvd u ⟶ 0 < degree v ⟶ degree v < degree u
⟶ ¬ v =m smult l (prod_mset ws))"
private definition "large_m u vs = (∀ v n. v dvd u ⟶ degree v ≤ degree_bound vs ⟶ 2 * abs (coeff v n) < m)"
lemma large_m_factor: "large_m u vs ⟹ v dvd u ⟹ large_m v vs"
unfolding large_m_def using dvd_trans by auto
lemma test_dvd_factor: assumes u: "u ≠ 0" and test: "test_dvd u ws" and vu: "v dvd u"
shows "test_dvd v ws"
proof -
from vu obtain w where uv: "u = v * w" unfolding dvd_def by auto
from u have deg: "degree u = degree v + degree w" unfolding uv
by (subst degree_mult_eq, auto)
show ?thesis unfolding test_dvd_def
proof (intro allI impI, goal_cases)
case (1 f l)
from 1(1) have fu: "f dvd u" unfolding uv by auto
from 1(3) have deg: "degree f < degree u" unfolding deg by auto
from test[unfolded test_dvd_def, rule_format, OF fu 1(2) deg]
show ?case .
qed
qed
lemma coprime_exp_mod: "coprime lu p ⟹ prime p ⟹ n ≠ 0 ⟹ lu mod p ^ n ≠ 0"
by (auto simp add: abs_of_pos prime_gt_0_int)
interpretation correct_subseqs_foldr_impl "λx. map_prod (mul_const x) (Cons x)" sl_impl sli by fact
lemma reconstruction: assumes
res: "reconstruction sl_impl m2 state u (smult lu u) lu d r vs res cands = fs"
and f: "f = u * prod_list res"
and meas: "meas = (r - d, cands)"
and dr: "d + d ≤ r"
and r: "r = length vs"
and cands: "set cands ⊆ S (lu,[]) vs d"
and d0: "d = 0 ⟹ cands = []"
and lu: "lu = lead_coeff u"
and factors: "unique_factorization_m u (lu,mset vs)"
and sf: "poly_mod.square_free_m p u"
and cop: "coprime lu p"
and norm: "⋀ v. v ∈ set vs ⟹ Mp v = v"
and tests: "⋀ ws. ws ⊆# mset vs ⟹ ws ≠ {#} ⟹
size ws < d ∨ size ws = d ∧ ws ∉ (mset o snd) ` set cands
⟹ test_dvd u ws"
and irr: "⋀ f. f ∈ set res ⟹ irreducible⇩d f"
and deg: "degree u > 0"
and cands_ne: "cands ≠ [] ⟹ d < r"
and large: "∀ v n. v dvd smult lu u ⟶ degree v ≤ degree_bound vs
⟶ 2 * abs (coeff v n) < m"
and f0: "f ≠ 0"
and state: "sli (lu,[]) vs d state"
and m2: "m2 = m div 2"
shows "f = prod_list fs ∧ (∀ fi ∈ set fs. irreducible⇩d fi)"
proof -
from large have large: "large_m (smult lu u) vs" unfolding large_m_def by auto
interpret p: poly_mod_prime p using prime by unfold_locales
define R where "R ≡ measures [
λ (n :: nat,cds :: (int × int poly list) list). n,
λ (n,cds). length cds]"
have wf: "wf R" unfolding R_def by simp
have mset_snd_S: "⋀ vs lu d. (mset ∘ snd) ` S (lu,[]) vs d =
{ ws. ws ⊆# mset vs ∧ size ws = d}"
by (fold mset_subseqs_size image_comp, unfold S_def image_Collect, auto)
have inv_M2[simp]: "inv_M2 m2 = inv_M" unfolding inv_M2_def m2 inv_M_def
by (intro ext, auto)
have inv_Mp2[simp]: "inv_Mp2 m2 = inv_Mp" unfolding inv_Mp2_def inv_Mp_def by simp
have p_Mp[simp]: "⋀ f. p.Mp (Mp f) = p.Mp f" using m p.m1 n Mp_Mp_pow_is_Mp by blast
{
fix u lu vs
assume eq: "Mp u = Mp (smult lu (prod_mset vs))" and cop: "coprime lu p" and size: "size vs ≠ 0"
and mi: "⋀ v. v ∈# vs ⟹ irreducible⇩d_m v ∧ monic v"
from cop p.m1 have lu0: "lu ≠ 0" by auto
from size have "vs ≠ {#}" by auto
then obtain v vs' where vs_v: "vs = vs' + {#v#}" by (cases vs, auto)
have mon: "monic (prod_mset vs)"
by (rule monic_prod_mset, insert mi, auto)
hence vs0: "prod_mset vs ≠ 0" by (metis coeff_0 zero_neq_one)
from mon have l_vs: "lead_coeff (prod_mset vs) = 1" .
have deg_ws: "degree_m (smult lu (prod_mset vs)) = degree (smult lu (prod_mset vs))"
by (rule degree_m_eq[OF _ m1], unfold lead_coeff_smult,
insert cop n p.m1 l_vs, auto simp: m)
with eq have "degree_m u = degree (smult lu (prod_mset vs))" by auto
also have "… = degree (prod_mset vs' * v)" unfolding degree_smult_eq vs_v using lu0 by (simp add:ac_simps)
also have "… = degree (prod_mset vs') + degree v"
by (rule degree_mult_eq, insert vs0[unfolded vs_v], auto)
also have "… ≥ degree v" by simp
finally have deg_v: "degree v ≤ degree_m u" .
from mi[unfolded vs_v, of v] have "irreducible⇩d_m v" by auto
hence "0 < degree_m v" unfolding irreducible⇩d_m_def by auto
also have "… ≤ degree v" by (rule degree_m_le)
also have "… ≤ degree_m u" by (rule deg_v)
also have "… ≤ degree u" by (rule degree_m_le)
finally have "degree u > 0" by auto
} note deg_non_zero = this
{
fix u :: "int poly" and vs :: "int poly list" and d :: nat
assume deg_u: "degree u > 0"
and cop: "coprime (lead_coeff u) p"
and uf: "unique_factorization_m u (lead_coeff u, mset vs)"
and sf: "p.square_free_m u"
and norm: "⋀ v. v ∈ set vs ⟹ Mp v = v"
and d: "size (mset vs) < d + d"
and tests: "⋀ ws. ws ⊆# mset vs ⟹ ws ≠ {#} ⟹ size ws < d ⟹ test_dvd u ws"
from deg_u have u0: "u ≠ 0" by auto
have "irreducible⇩d u"
proof (rule irreducible⇩dI[OF deg_u])
fix q q' :: "int poly"
assume deg: "degree q > 0" "degree q < degree u" "degree q' > 0" "degree q' < degree u"
and uq: "u = q * q'"
then have qu: "q dvd u" and q'u: "q' dvd u" by auto
from u0 have deg_u: "degree u = degree q + degree q'" unfolding uq
by (subst degree_mult_eq, auto)
from coprime_lead_coeff_factor[OF prime cop[unfolded uq]]
have cop_q: "coprime (lead_coeff q) p" "coprime (lead_coeff q') p" by auto
from unique_factorization_m_factor[OF prime uf[unfolded uq] _ _ n m, folded uq,
OF cop sf]
obtain fs gs l where uf_q: "unique_factorization_m q (lead_coeff q, fs)"
and uf_q': "unique_factorization_m q' (lead_coeff q', gs)"
and Mf_eq: "Mf (l, mset vs) = Mf (lead_coeff q * lead_coeff q', fs + gs)"
and fs_id: "image_mset Mp fs = fs"
and gs_id: "image_mset Mp gs = gs" by auto
from Mf_eq fs_id gs_id have "image_mset Mp (mset vs) = fs + gs"
unfolding Mf_def by auto
also have "image_mset Mp (mset vs) = mset vs" using norm by (induct vs, auto)
finally have eq: "mset vs = fs + gs" by simp
from uf_q[unfolded unique_factorization_m_alt_def factorization_m_def split]
have q_eq: "q =m smult (lead_coeff q) (prod_mset fs)" by auto
have "degree_m q = degree q"
by (rule degree_m_eq[OF _ m1], insert cop_q(1) n p.m1, unfold m,
auto simp:)
with q_eq have degm_q: "degree q = degree (Mp (smult (lead_coeff q) (prod_mset fs)))" by auto
with deg have fs_nempty: "fs ≠ {#}"
by (cases fs; cases "lead_coeff q = 0"; auto simp: Mp_def)
from uf_q'[unfolded unique_factorization_m_alt_def factorization_m_def split]
have q'_eq: "q' =m smult (lead_coeff q') (prod_mset gs)" by auto
have "degree_m q' = degree q'"
by (rule degree_m_eq[OF _ m1], insert cop_q(2) n p.m1, unfold m,
auto simp:)
with q'_eq have degm_q': "degree q' = degree (Mp (smult (lead_coeff q') (prod_mset gs)))" by auto
with deg have gs_nempty: "gs ≠ {#}"
by (cases gs; cases "lead_coeff q' = 0"; auto simp: Mp_def)
from eq have size: "size fs + size gs = size (mset vs)" by auto
with d have choice: "size fs < d ∨ size gs < d" by auto
from choice show False
proof
assume fs: "size fs < d"
from eq have sub: "fs ⊆# mset vs" using mset_subset_eq_add_left[of fs gs] by auto
have "test_dvd u fs"
by (rule tests[OF sub fs_nempty, unfolded Nil], insert fs, auto)
from this[unfolded test_dvd_def] uq deg q_eq show False by auto
next
assume gs: "size gs < d"
from eq have sub: "gs ⊆# mset vs" using mset_subset_eq_add_left[of fs gs] by auto
have "test_dvd u gs"
by (rule tests[OF sub gs_nempty, unfolded Nil], insert gs, auto)
from this[unfolded test_dvd_def] uq deg q'_eq show False unfolding uq by auto
qed
qed
} note irreducible⇩d_via_tests = this
show ?thesis using assms(1-16) large state
proof (induct meas arbitrary: u lu d r vs res cands state rule: wf_induct[OF wf])
case (1 meas u lu d r vs res cands state)
note IH = 1(1)[rule_format]
note res = 1(2)[unfolded reconstruction.simps[where cands = cands]]
note f = 1(3)
note meas = 1(4)
note dr = 1(5)
note r = 1(6)
note cands = 1(7)
note d0 = 1(8)
note lu = 1(9)
note factors = 1(10)
note sf = 1(11)
note cop = 1(12)
note norm = 1(13)
note tests = 1(14)
note irr = 1(15)
note deg_u = 1(16)
note cands_empty = 1(17)
note large = 1(18)
note state = 1(19)
from unique_factorization_m_zero[OF factors]
have Mlu0: "M lu ≠ 0" by auto
from Mlu0 have lu0: "lu ≠ 0" by auto
from this[unfolded lu] have u0: "u ≠ 0" by auto
from unique_factorization_m_imp_factorization[OF factors]
have fact: "factorization_m u (lu,mset vs)" by auto
from this[unfolded factorization_m_def split] norm
have vs: "u =m smult lu (prod_list vs)" and
vs_mi: "⋀ f. f∈#mset vs ⟹ irreducible⇩d_m f ∧ monic f" by auto
let ?luu = "smult lu u"
show ?case
proof (cases cands)
case Nil
note res = res[unfolded this]
let ?d' = "Suc d"
show ?thesis
proof (cases "r < ?d' + ?d'")
case True
with res have fs: "fs = u # res" by (simp add: Let_def)
from True[unfolded r] have size: "size (mset vs) < ?d' + ?d'" by auto
have "irreducible⇩d u"
by (rule irreducible⇩d_via_tests[OF deg_u cop[unfolded lu] factors(1)[unfolded lu]
sf norm size tests], auto simp: Nil)
with fs f irr show ?thesis by simp
next
case False
with dr have dr: "?d' + ?d' ≤ r" and dr': "?d' < r" by auto
obtain state' cands' where sln: "next_subseqs_foldr sl_impl state = (cands',state')" by force
from next_subseqs_foldr[OF sln state] have state': "sli (lu,[]) vs (Suc d) state'"
and cands': "set cands' = S (lu,[]) vs (Suc d)" by auto
let ?new = "subseqs_length mul_const lu ?d' vs"
have R: "((r - Suc d, cands'), meas) ∈ R" unfolding meas R_def using False by auto
from res False sln
have fact: "reconstruction sl_impl m2 state' u ?luu lu ?d' r vs res cands' = fs" by auto
show ?thesis
proof (rule IH[OF R fact f refl dr r _ _ lu factors sf cop norm _ irr deg_u dr' large state'], goal_cases)
case (4 ws)
show ?case
proof (cases "size ws = Suc d")
case False
with 4 have "size ws < Suc d" by auto
thus ?thesis by (intro tests[OF 4(1-2)], unfold Nil, auto)
next
case True
from 4(3)[unfolded cands' mset_snd_S] True 4(1) show ?thesis by auto
qed
qed (auto simp: cands')
qed
next
case (Cons c cds)
with d0 have d0: "d > 0" by auto
obtain lv' ws where c: "c = (lv',ws)" by force
let ?lv = "inv_M lv'"
define vb where "vb ≡ inv_Mp (Mp (smult lu (prod_list ws)))"
note res = res[unfolded Cons c list.simps split]
from cands[unfolded Cons c S_def] have ws: "ws ∈ set (subseqs vs)" "length ws = d"
and lv'': "lv' = foldr mul_const ws lu" by auto
from subseqs_sub_mset[OF ws(1)] have ws_vs: "mset ws ⊆# mset vs" "set ws ⊆ set vs"
using set_mset_mono subseqs_length_simple_False by auto fastforce
have mon_ws: "monic (prod_mset (mset ws))"
by (rule monic_prod_mset, insert ws_vs vs_mi, auto)
have l_ws: "lead_coeff (prod_mset (mset ws)) = 1" using mon_ws .
have lv': "M lv' = M (coeff (smult lu (prod_list ws)) 0)"
unfolding lv'' coeff_smult
by (induct ws arbitrary: lu, auto simp: mul_const_def M_def coeff_mult_0)
(metis mod_mult_right_eq mult.left_commute)
show ?thesis
proof (cases "?lv dvd coeff ?luu 0 ∧ vb dvd ?luu")
case False
have ndvd: "¬ vb dvd ?luu"
proof
assume dvd: "vb dvd ?luu"
hence "coeff vb 0 dvd coeff ?luu 0" by (metis coeff_mult_0 dvd_def)
with dvd False have "?lv ≠ coeff vb 0" by auto
also have "lv' = M lv'" using ws(2) d0 unfolding lv''
by (cases ws, force, simp add: M_def mul_const_def)
also have "inv_M (M lv') = coeff vb 0" unfolding vb_def inv_Mp_coeff Mp_coeff lv' by simp
finally show False by simp
qed
from False res
have res: "reconstruction sl_impl m2 state u ?luu lu d r vs res cds = fs"
unfolding vb_def Let_def by auto
have R: "((r - d, cds), meas) ∈ R" unfolding meas Cons R_def by auto
from cands have cands: "set cds ⊆ S (lu,[]) vs d"
unfolding Cons by auto
show ?thesis
proof (rule IH[OF R res f refl dr r cands _ lu factors sf cop norm _ irr deg_u _ large state], goal_cases)
case (3 ws')
show ?case
proof (cases "ws' = mset ws")
case False
show ?thesis
by (rule tests[OF 3(1-2)], insert 3(3) False, force simp: Cons c)
next
case True
have test: "test_dvd_exec lu u ws'"
unfolding True test_dvd_exec_def using ndvd unfolding vb_def by simp
show ?thesis unfolding test_dvd_def
proof (intro allI impI notI, goal_cases)
case (1 v l)
note deg_v = 1(2-3)
from 1(1) obtain w where u: "u = v * w" unfolding dvd_def by auto
from u0 have deg: "degree u = degree v + degree w" unfolding u
by (subst degree_mult_eq, auto)
define v' where "v' = smult (lead_coeff w) v"
define w' where "w' = smult (lead_coeff v) w"
let ?ws = "smult (lead_coeff w * l) (prod_mset ws')"
from arg_cong[OF 1(4), of "λ f. Mp (smult (lead_coeff w) f)"]
have v'_ws': "Mp v' = Mp ?ws" unfolding v'_def
by simp
from lead_coeff_factor[OF u, folded v'_def w'_def]
have prod: "?luu = v' * w'" and lc: "lead_coeff v' = lu" and "lead_coeff w' = lu"
unfolding lu by auto
with lu0 have lc0: "lead_coeff v ≠ 0" "lead_coeff w ≠ 0" unfolding v'_def w'_def by auto
from deg_v have deg_w: "0 < degree w" "degree w < degree u" unfolding deg by auto
from deg_v deg_w lc0
have deg: "0 < degree v'" "degree v' < degree u" "0 < degree w'" "degree w' < degree u"
unfolding v'_def w'_def by auto
from prod have v_dvd: "v' dvd ?luu" by auto
with test[unfolded test_dvd_exec_def]
have neq: "v' ≠ inv_Mp (Mp (smult lu (prod_mset ws')))" by auto
have deg_m_v': "degree_m v' = degree v'"
by (rule degree_m_eq[OF _ m1], unfold lc m,
insert cop prime n coprime_exp_mod, auto)
with v'_ws' have "degree v' = degree_m ?ws" by simp
also have "… ≤ degree_m (prod_mset ws')" by (rule degree_m_smult_le)
also have "… = degree_m (prod_list ws)" unfolding True by simp
also have "… ≤ degree (prod_list ws)" by (rule degree_m_le)
also have "… ≤ degree_bound vs"
using ws_vs(1) ws(2) dr[unfolded r] degree_bound by auto
finally have "degree v' ≤ degree_bound vs" .
from inv_Mp_rev[OF large[unfolded large_m_def, rule_format, OF v_dvd this]]
have inv: "inv_Mp (Mp v') = v'" by simp
from arg_cong[OF v'_ws', of inv_Mp, unfolded inv]
have v': "v' = inv_Mp (Mp ?ws)" by auto
have deg_ws: "degree_m ?ws = degree ?ws"
proof (rule degree_m_eq[OF _ m1],
unfold lead_coeff_smult True l_ws, rule)
assume "lead_coeff w * l * 1 mod m = 0"
hence 0: "M (lead_coeff w * l) = 0" unfolding M_def by simp
have "Mp ?ws = Mp (smult (M (lead_coeff w * l)) (prod_mset ws'))" by simp
also have "… = 0" unfolding 0 by simp
finally have "Mp ?ws = 0" by simp
hence "v' = 0" unfolding v' by (simp add: inv_Mp_def)
with deg show False by auto
qed
from arg_cong[OF v', of "λ f. lead_coeff (Mp f)", simplified]
have "M lu = M (lead_coeff v')" using lc by simp
also have "… = lead_coeff (Mp v')"
by (rule degree_m_eq_lead_coeff[OF deg_m_v', symmetric])
also have "… = lead_coeff (Mp ?ws)"
using arg_cong[OF v', of "λ f. lead_coeff (Mp f)"] by simp
also have "… = M (lead_coeff ?ws)"
by (rule degree_m_eq_lead_coeff[OF deg_ws])
also have "… = M (lead_coeff w * l)" unfolding lead_coeff_smult True l_ws by simp
finally have id: "M lu = M (lead_coeff w * l)" .
note v'
also have "Mp ?ws = Mp (smult (M (lead_coeff w * l)) (prod_mset ws'))" by simp
also have "… = Mp (smult lu (prod_mset ws'))" unfolding id[symmetric] by simp
finally show False using neq by simp
qed
qed
qed (insert d0 Cons cands_empty, auto)
next
case True
define pp_vb where "pp_vb ≡ primitive_part vb"
define u' where "u' ≡ u div pp_vb"
define lu' where "lu' ≡ lead_coeff u'"
let ?luu' = "smult lu' u'"
define vs' where "vs' ≡ fold remove1 ws vs"
obtain state' cands' where slc: "subseqs_foldr sl_impl (lu',[]) vs' d = (cands', state')" by force
from subseqs_foldr[OF slc] have state': "sli (lu',[]) vs' d state'"
and cands': "set cands' = S (lu',[]) vs' d" by auto
let ?res' = "pp_vb # res"
let ?r' = "r - length ws"
note defs = vb_def pp_vb_def u'_def lu'_def vs'_def slc
from fold_remove1_mset[OF subseqs_sub_mset[OF ws(1)]]
have vs_split: "mset vs = mset vs' + mset ws" unfolding vs'_def by auto
hence vs'_diff: "mset vs' = mset vs - mset ws" and ws_sub: "mset ws ⊆# mset vs" by auto
from arg_cong[OF vs_split, of size]
have r': "?r' = length vs'" unfolding defs r by simp
from arg_cong[OF vs_split, of prod_mset]
have prod_vs: "prod_list vs = prod_list vs' * prod_list ws" by simp
from arg_cong[OF vs_split, of set_mset] have set_vs: "set vs = set vs' ∪ set ws" by auto
note inv = inverse_mod_coprime_exp[OF m prime n]
note p_inv = p.inverse_mod_coprime[OF prime]
from True res slc
have res: "(if ?r' < d + d then u' # ?res' else reconstruction sl_impl m2 state'
u' ?luu' lu' d ?r' vs' ?res' cands') = fs"
unfolding Let_def defs by auto
from True have dvd: "vb dvd ?luu" by simp
from dvd_smult_int[OF lu0 this] have ppu: "pp_vb dvd u" unfolding defs by simp
hence u: "u = pp_vb * u'" unfolding u'_def
by (metis dvdE mult_eq_0_iff nonzero_mult_div_cancel_left)
hence uu': "u' dvd u" unfolding dvd_def by auto
have f: "f = u' * prod_list ?res'" using f u by auto
let ?fact = "smult lu (prod_mset (mset ws))"
have Mp_vb: "Mp vb = Mp (smult lu (prod_list ws))" unfolding vb_def by simp
have pp_vb_vb: "smult (content vb) pp_vb = vb" unfolding pp_vb_def by (rule content_times_primitive_part)
{
have "smult (content vb) u = (smult (content vb) pp_vb) * u'" unfolding u by simp
also have "smult (content vb) pp_vb = vb" by fact
finally have "smult (content vb) u = vb * u'" by simp
from arg_cong[OF this, of Mp]
have "Mp (Mp vb * u') = Mp (smult (content vb) u)" by simp
hence "Mp (smult (content vb) u) = Mp (?fact * u')" unfolding Mp_vb by simp
} note prod = this
from arg_cong[OF this, of p.Mp]
have prod': "p.Mp (smult (content vb) u) = p.Mp (?fact * u')" by simp
from dvd have "lead_coeff vb dvd lead_coeff (smult lu u)"
by (metis dvd_def lead_coeff_mult)
hence ldvd: "lead_coeff vb dvd lu * lu" unfolding lead_coeff_smult lu by simp
from cop have cop_lu: "coprime (lu * lu) p"
by simp
from coprime_divisors [OF ldvd dvd_refl] cop_lu
have cop_lvb: "coprime (lead_coeff vb) p" by simp
then have cop_vb: "coprime (content vb) p"
by (auto intro: coprime_divisors[OF content_dvd_coeff dvd_refl])
from u have "u' dvd u" unfolding dvd_def by auto
hence "lead_coeff u' dvd lu" unfolding lu by (metis dvd_def lead_coeff_mult)
from coprime_divisors[OF this dvd_refl] cop
have "coprime (lead_coeff u') p" by simp
hence "coprime (lu * lead_coeff u') p" and cop_lu': "coprime lu' p"
using cop by (auto simp: lu'_def)
hence cop': "coprime (lead_coeff (?fact * u')) p"
unfolding lead_coeff_mult lead_coeff_smult l_ws by simp
have "p.square_free_m (smult (content vb) u)" using cop_vb sf p_inv
by (auto intro!: p.square_free_m_smultI)
from p.square_free_m_cong[OF this prod']
have sf': "p.square_free_m (?fact * u')" by simp
from p.square_free_m_factor[OF this]
have sf_u': "p.square_free_m u'" by simp
have "unique_factorization_m (smult (content vb) u) (lu * content vb, mset vs)"
using cop_vb factors inv by (auto intro: unique_factorization_m_smult)
from unique_factorization_m_cong[OF this prod]
have uf: "unique_factorization_m (?fact * u') (lu * content vb, mset vs)" .
{
from unique_factorization_m_factor[OF prime uf cop' sf' n m]
obtain fs gs where uf1: "unique_factorization_m ?fact (lu, fs)"
and uf2: "unique_factorization_m u' (lu', gs)"
and eq: "Mf (lu * content vb, mset vs) = Mf (lu * lead_coeff u', fs + gs)"
unfolding lead_coeff_smult l_ws lu'_def
by auto
have "factorization_m ?fact (lu, mset ws)"
unfolding factorization_m_def split using set_vs vs_mi norm by auto
with uf1[unfolded unique_factorization_m_alt_def] have "Mf (lu,mset ws) = Mf (lu, fs)"
by blast
hence fs_ws: "image_mset Mp fs = image_mset Mp (mset ws)" unfolding Mf_def split by auto
from eq[unfolded Mf_def split]
have "image_mset Mp (mset vs) = image_mset Mp fs + image_mset Mp gs" by auto
from this[unfolded fs_ws vs_split] have gs: "image_mset Mp gs = image_mset Mp (mset vs')"
by (simp add: ac_simps)
from uf1 have uf1: "unique_factorization_m ?fact (lu, mset ws)"
unfolding unique_factorization_m_def Mf_def split fs_ws by simp
from uf2 have uf2: "unique_factorization_m u' (lu', mset vs')"
unfolding unique_factorization_m_def Mf_def split gs by simp
note uf1 uf2
}
hence factors: "unique_factorization_m u' (lu', mset vs')"
"unique_factorization_m ?fact (lu, mset ws)" by auto
have lu': "lu' = lead_coeff u'" unfolding lu'_def by simp
have vb0: "vb ≠ 0" using dvd lu0 u0 by auto
from ws(2) have size_ws: "size (mset ws) = d" by auto
with d0 have size_ws0: "size (mset ws) ≠ 0" by auto
then obtain w ws' where ws_w: "ws = w # ws'" by (cases ws, auto)
from Mp_vb have Mp_vb': "Mp vb = Mp (smult lu (prod_mset (mset ws)))" by auto
have deg_vb: "degree vb > 0"
by (rule deg_non_zero[OF Mp_vb' cop size_ws0 vs_mi], insert vs_split, auto)
also have "degree vb = degree pp_vb" using arg_cong[OF pp_vb_vb, of degree]
unfolding degree_smult_eq using vb0 by auto
finally have deg_pp: "degree pp_vb > 0" by auto
hence pp_vb0: "pp_vb ≠ 0" by auto
from factors(1)[unfolded unique_factorization_m_alt_def factorization_m_def]
have eq_u': "Mp u' = Mp (smult lu' (prod_mset (mset vs')))" by auto
from r'[unfolded ws(2)] dr have "length vs' + d = r" by auto
from this cands_empty[unfolded Cons] have "size (mset vs') ≠ 0" by auto
from deg_non_zero[OF eq_u' cop_lu' this vs_mi]
have deg_u': "degree u' > 0" unfolding vs_split by auto
have irr_pp: "irreducible⇩d pp_vb"
proof (rule irreducible⇩dI[OF deg_pp])
fix q r :: "int poly"
assume deg_q: "degree q > 0" "degree q < degree pp_vb"
and deg_r: "degree r > 0" "degree r < degree pp_vb"
and pp_qr: "pp_vb = q * r"
then have qvb: "q dvd pp_vb" by auto
from dvd_trans[OF qvb ppu] have qu: "q dvd u" .
have "degree pp_vb = degree q + degree r" unfolding pp_qr
by (subst degree_mult_eq, insert pp_qr pp_vb0, auto)
have uf: "unique_factorization_m (smult (content vb) pp_vb) (lu, mset ws)"
unfolding pp_vb_vb
by (rule unique_factorization_m_cong[OF factors(2)], insert Mp_vb, auto)
from unique_factorization_m_smultD[OF uf inv] cop_vb
have uf: "unique_factorization_m pp_vb (lu * inverse_mod (content vb) m, mset ws)" by auto
from ppu have "lead_coeff pp_vb dvd lu" unfolding lu by (metis dvd_def lead_coeff_mult)
from coprime_divisors[OF this dvd_refl] cop
have cop_pp: "coprime (lead_coeff pp_vb) p" by simp
from coprime_lead_coeff_factor[OF prime cop_pp[unfolded pp_qr]]
have cop_qr: "coprime (lead_coeff q) p" "coprime (lead_coeff r) p" by auto
from p.square_free_m_factor[OF sf[unfolded u]]
have sf_pp: "p.square_free_m pp_vb" by simp
from unique_factorization_m_factor[OF prime uf[unfolded pp_qr] _ _ n m,
folded pp_qr, OF cop_pp sf_pp]
obtain fs gs l where uf_q: "unique_factorization_m q (lead_coeff q, fs)"
and uf_r: "unique_factorization_m r (lead_coeff r, gs)"
and Mf_eq: "Mf (l, mset ws) = Mf (lead_coeff q * lead_coeff r, fs + gs)"
and fs_id: "image_mset Mp fs = fs"
and gs_id: "image_mset Mp gs = gs" by auto
from Mf_eq have "image_mset Mp (mset ws) = image_mset Mp fs + image_mset Mp gs"
unfolding Mf_def by auto
also have "image_mset Mp (mset ws) = mset ws" using norm ws_vs(2) by (induct ws, auto)
finally have eq: "mset ws = image_mset Mp fs + image_mset Mp gs" by simp
from arg_cong[OF this, of size, unfolded size_ws] have size: "size fs + size gs = d" by auto
from uf_q[unfolded unique_factorization_m_alt_def factorization_m_def split]
have q_eq: "q =m smult (lead_coeff q) (prod_mset fs)" by auto
have "degree_m q = degree q"
by (rule degree_m_eq[OF _ m1], insert cop_qr(1) n p.m1, unfold m,
auto simp:)
with q_eq have degm_q: "degree q = degree (Mp (smult (lead_coeff q) (prod_mset fs)))" by auto
with deg_q have fs_nempty: "fs ≠ {#}"
by (cases fs; cases "lead_coeff q = 0"; auto simp: Mp_def)
from uf_r[unfolded unique_factorization_m_alt_def factorization_m_def split]
have r_eq: "r =m smult (lead_coeff r) (prod_mset gs)" by auto
have "degree_m r = degree r"
by (rule degree_m_eq[OF _ m1], insert cop_qr(2) n p.m1, unfold m,
auto simp:)
with r_eq have degm_r: "degree r = degree (Mp (smult (lead_coeff r) (prod_mset gs)))" by auto
with deg_r have gs_nempty: "gs ≠ {#}"
by (cases gs; cases "lead_coeff r = 0"; auto simp: Mp_def)
from gs_nempty have "size gs ≠ 0" by auto
with size have size_fs: "size fs < d" by linarith
note * = tests[unfolded test_dvd_def, rule_format, OF _ fs_nempty _ qu, of "lead_coeff q"]
from ppu have "degree pp_vb ≤ degree u"
using dvd_imp_degree_le u0 by blast
with deg_q q_eq size_fs
have "¬ fs ⊆# mset vs" by (auto dest!:*)
thus False unfolding vs_split eq fs_id gs_id using mset_subset_eq_add_left[of fs "mset vs' + gs"]
by (auto simp: ac_simps)
qed
{
fix ws'
assume *: "ws' ⊆# mset vs'" "ws' ≠ {#}"
"size ws' < d ∨ size ws' = d ∧ ws' ∉ (mset ∘ snd) ` set cands'"
from *(1) have "ws' ⊆# mset vs" unfolding vs_split
by (simp add: subset_mset.add_increasing2)
from tests[OF this *(2)] *(3)[unfolded cands' mset_snd_S] *(1)
have "test_dvd u ws'" by auto
from test_dvd_factor[OF u0 this[unfolded lu] uu']
have "test_dvd u' ws'" .
} note tests' = this
show ?thesis
proof (cases "?r' < d + d")
case True
with res have res: "fs = u' # ?res'" by auto
from True r' have size: "size (mset vs') < d + d" by auto
have "irreducible⇩d u'"
by (rule irreducible⇩d_via_tests[OF deg_u' cop_lu'[unfolded lu'] factors(1)[unfolded lu']
sf_u' norm size tests'], insert set_vs, auto)
with f res irr irr_pp show ?thesis by auto
next
case False
have res: "reconstruction sl_impl m2 state' u' ?luu' lu' d ?r' vs' ?res' cands' = fs"
using False res by auto
from False have dr: "d + d ≤ ?r'" by auto
from False dr r r' d0 ws Cons have le: "?r' - d < r - d" by (cases ws, auto)
hence R: "((?r' - d, cands'), meas) ∈ R" unfolding meas R_def by simp
have dr': "d < ?r'" using le False ws(2) by linarith
have luu': "lu' dvd lu" using ‹lead_coeff u' dvd lu› unfolding lu' .
have "large_m (smult lu' u') vs"
by (rule large_m_factor[OF large dvd_dvd_smult], insert uu' luu')
moreover have "degree_bound vs' ≤ degree_bound vs"
unfolding vs'_def degree_bound_def by (rule max_factor_degree_mono)
ultimately have large': "large_m (smult lu' u') vs'" unfolding large_m_def by auto
show ?thesis
by (rule IH[OF R res f refl dr r' _ _ lu' factors(1) sf_u' cop_lu' norm tests' _ deg_u'
dr' large' state'], insert irr irr_pp d0 Cons set_vs, auto simp: cands')
qed
qed
qed
qed
qed
end
end
definition zassenhaus_reconstruction ::
"int poly list ⇒ int ⇒ nat ⇒ int poly ⇒ int poly list" where
"zassenhaus_reconstruction vs p n f = (let
mul = poly_mod.mul_const (p^n);
sl_impl = my_subseqs.impl (λx. map_prod (mul x) (Cons x))
in zassenhaus_reconstruction_generic sl_impl vs p n f)"
context
fixes p n f hs
assumes prime: "prime p"
and cop: "coprime (lead_coeff f) p"
and sf: "poly_mod.square_free_m p f"
and deg: "degree f > 0"
and bh: "berlekamp_hensel p n f = hs"
and bnd: "2 * ¦lead_coeff f¦ * factor_bound f (degree_bound hs) < p ^ n"
begin
private lemma n: "n ≠ 0"
proof
assume n: "n = 0"
hence pn: "p^n = 1" by auto
let ?f = "smult (lead_coeff f) f"
let ?d = "degree_bound hs"
have f: "f ≠ 0" using deg by auto
hence "lead_coeff f ≠ 0" by auto
hence lf: "abs (lead_coeff f) > 0" by auto
obtain c d where c: "factor_bound f (degree_bound hs) = c" "abs (lead_coeff f) = d" by auto
{
assume *: "1 ≤ c" "2 * d * c < 1" "0 < d"
hence "1 ≤ d" by auto
from mult_mono[OF this *(1)] * have "1 ≤ d * c" by auto
hence "2 * d * c ≥ 2" by auto
with * have False by auto
} note tedious = this
have "1 ≤ factor_bound f ?d"
using factor_bound[OF f, of 1 ?d 0] by auto
also have "… = 0" using bnd unfolding pn
using factor_bound_ge_0[of f "degree_bound hs", OF f] lf unfolding c
by (cases "c ≥ 1"; insert tedious, auto)
finally show False by simp
qed
interpretation p: poly_mod_prime p using prime by unfold_locales
lemma zassenhaus_reconstruction_generic:
assumes sl_impl: "correct_subseqs_foldr_impl (λv. map_prod (poly_mod.mul_const (p^n) v) (Cons v)) sl_impl sli"
and res: "zassenhaus_reconstruction_generic sl_impl hs p n f = fs"
shows "f = prod_list fs ∧ (∀ fi ∈ set fs. irreducible⇩d fi)"
proof -
let ?lc = "lead_coeff f"
let ?ff = "smult ?lc f"
let ?q = "p^n"
have p1: "p > 1" using prime unfolding prime_int_iff by simp
interpret poly_mod_2 "p^n" using p1 n unfolding poly_mod_2_def by simp
obtain cands state where slc: "subseqs_foldr sl_impl (lead_coeff f, []) hs 0 = (cands, state)" by force
interpret correct_subseqs_foldr_impl "λx. map_prod (mul_const x) (Cons x)" sl_impl sli by fact
from subseqs_foldr[OF slc] have state: "sli (lead_coeff f, []) hs 0 state" by auto
from res[unfolded zassenhaus_reconstruction_generic_def bh split Let_def slc fst_conv]
have res: "reconstruction sl_impl (?q div 2) state f ?ff ?lc 0 (length hs) hs [] [] = fs" by auto
from p.berlekamp_hensel_unique[OF cop sf bh n]
have ufact: "unique_factorization_m f (?lc, mset hs)" by simp
note bh = p.berlekamp_hensel[OF cop sf bh n]
from deg have f0: "f ≠ 0" and lf0: "?lc ≠ 0" by auto
hence ff0: "?ff ≠ 0" by auto
have bnd: "∀g k. g dvd ?ff ⟶ degree g ≤ degree_bound hs ⟶ 2 * ¦coeff g k¦ < p ^ n"
proof (intro allI impI, goal_cases)
case (1 g k)
from factor_bound_smult[OF f0 lf0 1, of k]
have "¦coeff g k¦ ≤ ¦?lc¦ * factor_bound f (degree_bound hs)" .
hence "2 * ¦coeff g k¦ ≤ 2 * ¦?lc¦ * factor_bound f (degree_bound hs)" by auto
also have "… < p^n" using bnd .
finally show ?case .
qed
note bh' = bh[unfolded factorization_m_def split]
have deg_f: "degree_m f = degree f"
using cop unique_factorization_m_zero [OF ufact] n
by (auto simp add: M_def intro: degree_m_eq [OF _ m1])
have mon_hs: "monic (prod_list hs)" using bh' by (auto intro: monic_prod_list)
have Mlc: "M ?lc ∈ {1 ..< p^n}"
by (rule prime_cop_exp_poly_mod[OF prime cop n])
hence "?lc ≠ 0" by auto
hence f0: "f ≠ 0" by auto
have degm: "degree_m (smult ?lc (prod_list hs)) = degree (smult ?lc (prod_list hs))"
by (rule degree_m_eq[OF _ m1], insert n bh mon_hs Mlc, auto simp: M_def)
from reconstruction[OF prime refl n sl_impl res _ refl _ refl _ refl refl ufact sf
cop _ _ _ deg _ bnd f0] bh(2) state
show ?thesis by simp
qed
lemma zassenhaus_reconstruction_irreducible⇩d:
assumes res: "zassenhaus_reconstruction hs p n f = fs"
shows "f = prod_list fs ∧ (∀ fi ∈ set fs. irreducible⇩d fi)"
by (rule zassenhaus_reconstruction_generic[OF my_subseqs.impl_correct
res[unfolded zassenhaus_reconstruction_def Let_def]])
corollary zassenhaus_reconstruction:
assumes pr: "primitive f"
assumes res: "zassenhaus_reconstruction hs p n f = fs"
shows "f = prod_list fs ∧ (∀ fi ∈ set fs. irreducible fi)"
using zassenhaus_reconstruction_irreducible⇩d[OF res] pr
irreducible_primitive_connect[OF primitive_prod_list]
by auto
end
end
Theory Code_Abort_Gcd
theory Code_Abort_Gcd
imports
"HOL-Computational_Algebra.Polynomial_Factorial"
begin
text ‹Dummy code-setup for @{const Gcd} and @{const Lcm} in the presence of
Container.›
definition dummy_Gcd where "dummy_Gcd x = Gcd x"
definition dummy_Lcm where "dummy_Lcm x = Lcm x"
declare [[code abort: dummy_Gcd]]
lemma dummy_Gcd_Lcm: "Gcd x = dummy_Gcd x" "Lcm x = dummy_Lcm x"
unfolding dummy_Gcd_def dummy_Lcm_def by auto
lemmas dummy_Gcd_Lcm_poly [code] = dummy_Gcd_Lcm
[where ?'a = "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"]
lemmas dummy_Gcd_Lcm_int [code] = dummy_Gcd_Lcm [where ?'a = int]
lemmas dummy_Gcd_Lcm_nat [code] = dummy_Gcd_Lcm [where ?'a = nat]
declare [[code abort: Euclidean_Algorithm.Gcd Euclidean_Algorithm.Lcm]]
end
Theory Berlekamp_Zassenhaus
section ‹The Polynomial Factorization Algorithm›
subsection ‹Factoring Square-Free Integer Polynomials›
text ‹We combine all previous results, i.e., Berlekamp's algorithm, Hensel-lifting, the reconstruction
of Zassenhaus, Mignotte-bounds, etc., to eventually assemble the factorization algorithm for
integer polynomials.›
theory Berlekamp_Zassenhaus
imports
Berlekamp_Hensel
Polynomial_Factorization.Gauss_Lemma
Polynomial_Factorization.Dvd_Int_Poly
Reconstruction
Suitable_Prime
Degree_Bound
Code_Abort_Gcd
begin
context
begin
private partial_function (tailrec) find_exponent_main :: "int ⇒ int ⇒ nat ⇒ int ⇒ nat" where
[code]: "find_exponent_main p pm m bnd = (if pm > bnd then m
else find_exponent_main p (pm * p) (Suc m) bnd)"
definition find_exponent :: "int ⇒ int ⇒ nat" where
"find_exponent p bnd = find_exponent_main p p 1 bnd"
lemma find_exponent: assumes p: "p > 1"
shows "p ^ find_exponent p bnd > bnd" "find_exponent p bnd ≠ 0"
proof -
{
fix m and n
assume "n = nat (1 + bnd - p^m)" and "m ≥ 1"
hence "bnd < p ^ find_exponent_main p (p^m) m bnd ∧ find_exponent_main p (p^m) m bnd ≥ 1"
proof (induct n arbitrary: m rule: less_induct)
case (less n m)
note simp = find_exponent_main.simps[of p "p^m"]
show ?case
proof (cases "bnd < p ^ m")
case True
thus ?thesis using less unfolding simp by simp
next
case False
hence id: "find_exponent_main p (p ^ m) m bnd = find_exponent_main p (p ^ Suc m) (Suc m) bnd"
unfolding simp by (simp add: ac_simps)
show ?thesis unfolding id
by (rule less(1)[OF _ refl], unfold less(2), insert False p, auto)
qed
qed
}
from this[OF refl, of 1]
show "p ^ find_exponent p bnd > bnd" "find_exponent p bnd ≠ 0"
unfolding find_exponent_def by auto
qed
end
definition berlekamp_zassenhaus_factorization :: "int poly ⇒ int poly list" where
"berlekamp_zassenhaus_factorization f = (let
p = suitable_prime_bz f;
(_, fs) = finite_field_factorization_int p f;
max_deg = degree_bound fs;
bnd = 2 * ¦lead_coeff f¦ * factor_bound f max_deg;
k = find_exponent p bnd;
vs = hensel_lifting p k f fs
in zassenhaus_reconstruction vs p k f)"
theorem berlekamp_zassenhaus_factorization_irreducible⇩d:
assumes res: "berlekamp_zassenhaus_factorization f = fs"
and sf: "square_free f"
and deg: "degree f > 0"
shows "f = prod_list fs ∧ (∀ fi ∈ set fs. irreducible⇩d fi)"
proof -
let ?lc = "lead_coeff f"
define p where "p ≡ suitable_prime_bz f"
obtain c gs where berl: "finite_field_factorization_int p f = (c,gs)" by force
let ?degs = "map degree gs"
note res = res[unfolded berlekamp_zassenhaus_factorization_def Let_def, folded p_def,
unfolded berl split, folded]
from suitable_prime_bz[OF sf refl]
have prime: "prime p" and cop: "coprime ?lc p" and sf: "poly_mod.square_free_m p f"
unfolding p_def by auto
from prime interpret poly_mod_prime p by unfold_locales
define n where "n = find_exponent p (2 * abs ?lc * factor_bound f (degree_bound gs))"
note n = find_exponent[OF m1, of "2 * abs ?lc * factor_bound f (degree_bound gs)",
folded n_def]
note bh = berlekamp_and_hensel_separated[OF cop sf refl berl n(2)]
have db: "degree_bound (berlekamp_hensel p n f) = degree_bound gs" unfolding bh
degree_bound_def max_factor_degree_def by simp
note res = res[folded n_def bh(1)]
show ?thesis
by (rule zassenhaus_reconstruction_irreducible⇩d[OF prime cop sf deg refl _ res], insert n db, auto)
qed
corollary berlekamp_zassenhaus_factorization_irreducible:
assumes res: "berlekamp_zassenhaus_factorization f = fs"
and sf: "square_free f"
and pr: "primitive f"
and deg: "degree f > 0"
shows "f = prod_list fs ∧ (∀ fi ∈ set fs. irreducible fi)"
using pr irreducible_primitive_connect[OF primitive_prod_list]
berlekamp_zassenhaus_factorization_irreducible⇩d[OF res sf deg] by auto
end
Theory Gcd_Finite_Field_Impl
subsection ‹A fast coprimality approximation›
text ‹We adapt the integer polynomial gcd algorithm so that it
first tests whether $f$ and $g$ are coprime modulo a few primes.
If so, we are immediately done.›
theory Gcd_Finite_Field_Impl
imports
Suitable_Prime
Code_Abort_Gcd
"HOL-Library.Code_Target_Int"
begin
definition coprime_approx_main :: "int ⇒ 'i arith_ops_record ⇒ int poly ⇒ int poly ⇒ bool" where
"coprime_approx_main p ff_ops f g = (gcd_poly_i ff_ops (of_int_poly_i ff_ops (poly_mod.Mp p f))
(of_int_poly_i ff_ops (poly_mod.Mp p g)) = one_poly_i ff_ops)"
lemma (in prime_field_gen) coprime_approx_main:
shows "coprime_approx_main p ff_ops f g ⟹ coprime_m f g"
proof -
define F where F: "(F :: 'a mod_ring poly) = of_int_poly (Mp f)"
define G where G: "(G :: 'a mod_ring poly) = of_int_poly (Mp g)" let ?f' = "of_int_poly_i ff_ops (Mp f)"
let ?g' = "of_int_poly_i ff_ops (Mp g)"
define f'' where "f'' ≡ of_int_poly (Mp f) :: 'a mod_ring poly"
define g'' where "g'' ≡ of_int_poly (Mp g) :: 'a mod_ring poly"
have rel_f[transfer_rule]: "poly_rel ?f' f''"
by (rule poly_rel_of_int_poly[OF refl], simp add: f''_def)
have rel_f[transfer_rule]: "poly_rel ?g' g''"
by (rule poly_rel_of_int_poly[OF refl], simp add: g''_def)
have id: "(gcd_poly_i ff_ops (of_int_poly_i ff_ops (Mp f)) (of_int_poly_i ff_ops (Mp g)) = one_poly_i ff_ops)
= coprime f'' g''" (is "?P ⟷ ?Q")
proof -
have "?P ⟷ gcd f'' g'' = 1"
unfolding separable_i_def by transfer_prover
also have "… ⟷ ?Q"
by (simp add: coprime_iff_gcd_eq_1)
finally show ?thesis .
qed
have fF: "MP_Rel (Mp f) F" unfolding F MP_Rel_def
by (simp add: Mp_f_representative)
have gG: "MP_Rel (Mp g) G" unfolding G MP_Rel_def
by (simp add: Mp_f_representative)
have "coprime f'' g'' = coprime F G" unfolding f''_def F g''_def G by simp
also have "… = coprime_m (Mp f) (Mp g)"
using coprime_MP_Rel[unfolded rel_fun_def, rule_format, OF fF gG] by simp
also have "… = coprime_m f g" unfolding coprime_m_def dvdm_def by simp
finally have id2: "coprime f'' g'' = coprime_m f g" .
show "coprime_approx_main p ff_ops f g ⟹ coprime_m f g" unfolding coprime_approx_main_def
id id2 by auto
qed
context poly_mod_prime begin
lemmas coprime_approx_main_uint32 = prime_field_gen.coprime_approx_main[OF
prime_field.prime_field_finite_field_ops32, unfolded prime_field_def mod_ring_locale_def
poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
lemmas coprime_approx_main_uint64 = prime_field_gen.coprime_approx_main[OF
prime_field.prime_field_finite_field_ops64, unfolded prime_field_def mod_ring_locale_def
poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]
end
lemma coprime_mod_imp_coprime: assumes
p: "prime p" and
cop_m: "poly_mod.coprime_m p f g" and
cop: "coprime (lead_coeff f) p ∨ coprime (lead_coeff g) p" and
cnt: "content f = 1 ∨ content g = 1"
shows "coprime f g"
proof -
interpret poly_mod_prime p by (standard, rule p)
from cop_m[unfolded coprime_m_def] have cop_m: "⋀ h. h dvdm f ⟹ h dvdm g ⟹ h dvdm 1" by auto
show ?thesis
proof (rule coprimeI)
fix h
assume dvd: "h dvd f" "h dvd g"
hence "h dvdm f" "h dvdm g" unfolding dvdm_def dvd_def by auto
from cop_m[OF this] obtain k where unit: "Mp (h * Mp k) = 1" unfolding dvdm_def by auto
from content_dvd_contentI[OF dvd(1)] content_dvd_contentI[OF dvd(2)] cnt
have cnt: "content h = 1" by auto
let ?k = "Mp k"
from unit have h0: "h ≠ 0" by auto
from unit have k0: "?k ≠ 0" by fastforce
from p have p0: "p ≠ 0" by auto
from dvd have "lead_coeff h dvd lead_coeff f" "lead_coeff h dvd lead_coeff g"
by (metis dvd_def lead_coeff_mult)+
with cop have coph: "coprime (lead_coeff h) p"
by (meson dvd_trans not_coprime_iff_common_factor)
let ?k = "Mp k"
from arg_cong[OF unit, of degree] have degm0: "degree_m (h * ?k) = 0" by simp
have "lead_coeff ?k ∈ {0 ..< p}" unfolding Mp_coeff M_def using m1 by simp
with k0 have lk: "lead_coeff ?k ≥ 1" "lead_coeff ?k < p"
by (auto simp add: int_one_le_iff_zero_less order.not_eq_order_implies_strict)
have id: "lead_coeff (h * ?k) = lead_coeff h * lead_coeff ?k" unfolding lead_coeff_mult ..
from coph prime lk have "coprime (lead_coeff h * lead_coeff ?k) p"
by (simp add: ac_simps prime_imp_coprime zdvd_not_zless)
with id have cop_prod: "coprime (lead_coeff (h * ?k)) p" by simp
from h0 k0 have lc0: "lead_coeff (h * ?k) ≠ 0"
unfolding lead_coeff_mult by auto
from p have lcp: "lead_coeff (h * ?k) mod p ≠ 0"
using M_1 M_def cop_prod by auto
have deg_eq: "degree_m (h * ?k) = degree (h * Mp k)"
by (rule degree_m_eq[OF _ m1], insert lcp)
from this[unfolded degm0] have "degree (h * Mp k) = 0" by simp
with degree_mult_eq[OF h0 k0] have deg0: "degree h = 0" by auto
from degree0_coeffs[OF this] obtain h0 where h: "h = [:h0:]" by auto
have "content h = abs h0" unfolding content_def h by (cases "h0 = 0", auto)
hence "abs h0 = 1" using cnt by auto
hence "h0 ∈ {-1,1}" by auto
hence "h = 1 ∨ h = -1" unfolding h by (auto)
thus "is_unit h" by auto
qed
qed
text ‹We did not try to optimize the set of chosen primes. They have just been picked
randomly from a list of primes.›
definition gcd_primes32 :: "int list" where
"gcd_primes32 = [383, 1409, 19213, 22003, 41999]"
lemma gcd_primes32: "p ∈ set gcd_primes32 ⟹ prime p ∧ p ≤ 65535"
proof -
have "list_all (λ p. prime p ∧ p ≤ 65535) gcd_primes32" by eval
thus "p ∈ set gcd_primes32 ⟹ prime p ∧ p ≤ 65535" by (auto simp: list_all_iff)
qed
definition gcd_primes64 :: "int list" where
"gcd_primes64 = [383, 21984191, 50329901, 80329901, 219849193]"
lemma gcd_primes64: "p ∈ set gcd_primes64 ⟹ prime p ∧ p ≤ 4294967295"
proof -
have "list_all (λ p. prime p ∧ p ≤ 4294967295) gcd_primes64" by eval
thus "p ∈ set gcd_primes64 ⟹ prime p ∧ p ≤ 4294967295" by (auto simp: list_all_iff)
qed
definition coprime_heuristic :: "int poly ⇒ int poly ⇒ bool" where
"coprime_heuristic f g = (let lcf = lead_coeff f; lcg = lead_coeff g in
find (λ p. (coprime lcf p ∨ coprime lcg p) ∧ coprime_approx_main p (finite_field_ops64 (uint64_of_int p)) f g)
gcd_primes64 ≠ None)"
lemma coprime_heuristic: assumes "coprime_heuristic f g"
and "content f = 1 ∨ content g = 1"
shows "coprime f g"
proof (cases "find (λp. (coprime (lead_coeff f) p ∨ coprime (lead_coeff g) p) ∧
coprime_approx_main p (finite_field_ops64 (uint64_of_int p)) f g)
gcd_primes64")
case (Some p)
from find_Some_D[OF Some] gcd_primes64 have p: "prime p" and small: "p ≤ 4294967295"
and cop: "coprime (lead_coeff f) p ∨ coprime (lead_coeff g) p"
and copp: "coprime_approx_main p (finite_field_ops64 (uint64_of_int p)) f g" by auto
interpret poly_mod_prime p using p by unfold_locales
from coprime_approx_main_uint64[OF small copp] have "poly_mod.coprime_m p f g" by auto
from coprime_mod_imp_coprime[OF p this cop assms(2)] show "coprime f g" .
qed (insert assms(1)[unfolded coprime_heuristic_def], auto simp: Let_def)
definition gcd_int_poly :: "int poly ⇒ int poly ⇒ int poly" where
"gcd_int_poly f g =
(if f = 0 then normalize g
else if g = 0 then normalize f
else let
cf = Polynomial.content f;
cg = Polynomial.content g;
ct = gcd cf cg;
ff = map_poly (λ x. x div cf) f;
gg = map_poly (λ x. x div cg) g
in if coprime_heuristic ff gg then [:ct:] else smult ct (gcd_poly_code_aux ff gg))"
lemma gcd_int_poly_code[code_unfold]: "gcd = gcd_int_poly"
proof (intro ext)
fix f g :: "int poly"
let ?ff = "primitive_part f"
let ?gg = "primitive_part g"
note d = gcd_int_poly_def gcd_poly_code gcd_poly_code_def
show "gcd f g = gcd_int_poly f g"
proof (cases "f = 0 ∨ g = 0 ∨ ¬ coprime_heuristic ?ff ?gg")
case True
thus ?thesis unfolding d by (auto simp: Let_def primitive_part_def)
next
case False
hence cop: "coprime_heuristic ?ff ?gg" by simp
from False have "f ≠ 0" by auto
from content_primitive_part[OF this] coprime_heuristic[OF cop]
have id: "gcd ?ff ?gg = 1" by auto
show ?thesis unfolding gcd_poly_decompose[of f g] unfolding gcd_int_poly_def Let_def id
using False by (auto simp: primitive_part_def)
qed
qed
end
Theory Square_Free_Factorization_Int
theory Square_Free_Factorization_Int
imports
Square_Free_Int_To_Square_Free_GFp
Suitable_Prime
Code_Abort_Gcd
Gcd_Finite_Field_Impl
begin
definition yun_wrel :: "int poly ⇒ rat ⇒ rat poly ⇒ bool" where
"yun_wrel F c f = (map_poly rat_of_int F = smult c f)"
definition yun_rel :: "int poly ⇒ rat ⇒ rat poly ⇒ bool" where
"yun_rel F c f = (yun_wrel F c f
∧ content F = 1 ∧ lead_coeff F > 0 ∧ monic f)"
definition yun_erel :: "int poly ⇒ rat poly ⇒ bool" where
"yun_erel F f = (∃ c. yun_rel F c f)"
lemma yun_wrelD: assumes "yun_wrel F c f"
shows "map_poly rat_of_int F = smult c f"
using assms unfolding yun_wrel_def by auto
lemma yun_relD: assumes "yun_rel F c f"
shows "yun_wrel F c f" "map_poly rat_of_int F = smult c f"
"degree F = degree f" "F ≠ 0" "lead_coeff F > 0" "monic f"
"f = 1 ⟷ F = 1" "content F = 1"
proof -
note * = assms[unfolded yun_rel_def yun_wrel_def, simplified]
then have "degree (map_poly rat_of_int F) = degree f" by auto
then show deg: "degree F = degree f" by simp
show "F ≠ 0" "lead_coeff F > 0" "monic f" "content F = 1"
"map_poly rat_of_int F = smult c f"
"yun_wrel F c f" using * by (auto simp: yun_wrel_def)
{
assume "f = 1"
with deg have "degree F = 0" by auto
from degree0_coeffs[OF this] obtain c where F: "F = [:c:]" and c: "c = lead_coeff F" by auto
from c * have c0: "c > 0" by auto
hence cF: "content F = c" unfolding F content_def by auto
with * have "c = 1" by auto
with F have "F = 1" by simp
}
moreover
{
assume "F = 1"
with deg have "degree f = 0" by auto
with ‹monic f› have "f = 1"
using monic_degree_0 by blast
}
ultimately show "(f = 1) ⟷ (F = 1)" by auto
qed
lemma yun_erel_1_eq: assumes "yun_erel F f"
shows "(F = 1) ⟷ (f = 1)"
proof -
from assms[unfolded yun_erel_def] obtain c where "yun_rel F c f" by auto
from yun_relD[OF this] show ?thesis by simp
qed
lemma yun_rel_1[simp]: "yun_rel 1 1 1"
by (auto simp: yun_rel_def yun_wrel_def content_def)
lemma yun_erel_1[simp]: "yun_erel 1 1" unfolding yun_erel_def using yun_rel_1 by blast
lemma yun_rel_mult: "yun_rel F c f ⟹ yun_rel G d g ⟹ yun_rel (F * G) (c * d) (f * g)"
unfolding yun_rel_def yun_wrel_def content_mult lead_coeff_mult
by (auto simp: monic_mult hom_distribs)
lemma yun_erel_mult: "yun_erel F f ⟹ yun_erel G g ⟹ yun_erel (F * G) (f * g)"
unfolding yun_erel_def using yun_rel_mult[of F _ f G _ g] by blast
lemma yun_rel_pow: assumes "yun_rel F c f"
shows "yun_rel (F^n) (c^n) (f^n)"
by (induct n, insert assms yun_rel_mult, auto)
lemma yun_erel_pow: "yun_erel F f ⟹ yun_erel (F^n) (f^n)"
using yun_rel_pow unfolding yun_erel_def by blast
lemma yun_wrel_pderiv: assumes "yun_wrel F c f"
shows "yun_wrel (pderiv F) c (pderiv f)"
by (unfold yun_wrel_def, simp add: yun_wrelD[OF assms] pderiv_smult hom_distribs)
lemma yun_wrel_minus: assumes "yun_wrel F c f" "yun_wrel G c g"
shows "yun_wrel (F - G) c (f - g)"
using assms unfolding yun_wrel_def by (auto simp: smult_diff_right hom_distribs)
lemma yun_wrel_div: assumes f: "yun_wrel F c f" and g: "yun_wrel G d g"
and dvd: "G dvd F" "g dvd f"
and G0: "G ≠ 0"
shows "yun_wrel (F div G) (c / d) (f div g)"
proof -
let ?r = "rat_of_int"
let ?rp = "map_poly ?r"
from dvd obtain H h where fgh: "F = G * H" "f = g * h" unfolding dvd_def by auto
from G0 yun_wrelD[OF g] have g0: "g ≠ 0" and d0: "d ≠ 0" by auto
from arg_cong[OF fgh(1), of "λ x. x div G"] have H: "H = F div G" using G0 by simp
from arg_cong[OF fgh(1), of ?rp] have "?rp F = ?rp G * ?rp H" by (auto simp: hom_distribs)
from arg_cong[OF this, of "λ x. x div ?rp G"] G0 have id: "?rp H = ?rp F div ?rp G" by auto
have "?rp (F div G) = ?rp F div ?rp G" unfolding H[symmetric] id by simp
also have "… = smult c f div smult d g" using f g unfolding yun_wrel_def by auto
also have "… = smult (c / d) (f div g)" unfolding div_smult_right[OF d0] div_smult_left
by (simp add: field_simps)
finally show ?thesis unfolding yun_wrel_def by simp
qed
lemma yun_rel_div: assumes f: "yun_rel F c f" and g: "yun_rel G d g"
and dvd: "G dvd F" "g dvd f"
shows "yun_rel (F div G) (c / d) (f div g)"
proof -
note ff = yun_relD[OF f]
note gg = yun_relD[OF g]
show ?thesis unfolding yun_rel_def
proof (intro conjI)
from yun_wrel_div[OF ff(1) gg(1) dvd gg(4)]
show "yun_wrel (F div G) (c / d) (f div g)" by auto
from dvd have fg: "f = g * (f div g)" by auto
from arg_cong[OF fg, of monic] ff(6) gg(6)
show "monic (f div g)" using monic_factor by blast
from dvd have FG: "F = G * (F div G)" by auto
from arg_cong[OF FG, of content, unfolded content_mult] ff(8) gg(8)
show "content (F div G) = 1" by simp
from arg_cong[OF FG, of lead_coeff, unfolded lead_coeff_mult] ff(5) gg(5)
show "lead_coeff (F div G) > 0" by (simp add: zero_less_mult_iff)
qed
qed
lemma yun_wrel_gcd: assumes "yun_wrel F c' f" "yun_wrel G c g" and c: "c' ≠ 0" "c ≠ 0"
and d: "d = rat_of_int (lead_coeff (gcd F G))" "d ≠ 0"
shows "yun_wrel (gcd F G) d (gcd f g)"
proof -
let ?r = "rat_of_int"
let ?rp = "map_poly ?r"
have "smult d (gcd f g) = smult d (gcd (smult c' f) (smult c g))"
by (simp add: c gcd_smult_left gcd_smult_right)
also have "… = smult d (gcd (?rp F) (?rp G))" using assms(1-2)[unfolded yun_wrel_def] by simp
also have "… = smult (d * inverse d) (?rp (gcd F G))"
unfolding gcd_rat_to_gcd_int d by simp
also have "d * inverse d = 1" using d by auto
finally show ?thesis unfolding yun_wrel_def by simp
qed
lemma yun_rel_gcd: assumes f: "yun_rel F c f" and g: "yun_wrel G c' g" and c': "c' ≠ 0"
and d: "d = rat_of_int (lead_coeff (gcd F G))"
shows "yun_rel (gcd F G) d (gcd f g)"
unfolding yun_rel_def
proof (intro conjI)
note ff = yun_relD[OF f]
from ff have c0: "c ≠ 0" by auto
from ff d have d0: "d ≠ 0" by auto
from yun_wrel_gcd[OF ff(1) g c0 c' d d0]
show "yun_wrel (gcd F G) d (gcd f g)" by auto
from ff have "gcd f g ≠ 0" by auto
thus "monic (gcd f g)" by (simp add: poly_gcd_monic)
obtain H where H: "gcd F G = H" by auto
obtain lc where lc: "coeff H (degree H) = lc" by auto
from ff have "gcd F G ≠ 0" by auto
hence "H ≠ 0" "lc ≠ 0" unfolding H[symmetric] lc[symmetric] by auto
thus "0 < lead_coeff (gcd F G)" unfolding
arg_cong[OF normalize_gcd[of F G], of lead_coeff, symmetric]
unfolding normalize_poly_eq_map_poly H
by (auto, subst Polynomial.coeff_map_poly, auto,
subst Polynomial.degree_map_poly, auto simp: sgn_if)
have "H dvd F" unfolding H[symmetric] by auto
then obtain K where F: "F = H * K" unfolding dvd_def by auto
from arg_cong[OF this, of content, unfolded content_mult ff(8)]
content_ge_0_int[of H] have "content H = 1"
by (auto simp add: zmult_eq_1_iff)
thus "content (gcd F G) = 1" unfolding H .
qed
lemma yun_factorization_main_int: assumes f: "f = p div gcd p (pderiv p)"
and "g = pderiv p div gcd p (pderiv p)" "monic p"
and "yun_gcd.yun_factorization_main gcd f g i hs = res"
and "yun_gcd.yun_factorization_main gcd F G i Hs = Res"
and "yun_rel F c f" "yun_wrel G c g" "list_all2 (rel_prod yun_erel (=)) Hs hs"
shows "list_all2 (rel_prod yun_erel (=)) Res res"
proof -
let ?P = "λ f g. ∀ i hs res F G Hs Res c.
yun_gcd.yun_factorization_main gcd f g i hs = res
⟶ yun_gcd.yun_factorization_main gcd F G i Hs = Res
⟶ yun_rel F c f ⟶ yun_wrel G c g ⟶ list_all2 (rel_prod yun_erel (=)) Hs hs
⟶ list_all2 (rel_prod yun_erel (=)) Res res"
note simps = yun_gcd.yun_factorization_main.simps
note rel = yun_relD
let ?rel = "λ F f. map_poly rat_of_int F = smult (rat_of_int (lead_coeff F)) f"
show ?thesis
proof (induct rule: yun_factorization_induct[of ?P, rule_format, OF _ _ assms])
case (1 f g i hs res F G Hs Res c)
from rel[OF 1(4)] 1(1) have "f = 1" "F = 1" by auto
from 1(2-3)[unfolded simps[of _ 1] this] have "res = hs" "Res = Hs" by auto
with 1(6) show ?case by simp
next
case (2 f g i hs res F G Hs Res c)
define d where "d = g - pderiv f"
define a where "a = gcd f d"
define D where "D = G - pderiv F"
define A where "A = gcd F D"
note f = 2(5)
note g = 2(6)
note hs = 2(7)
note f1 = 2(1)
from f1 rel[OF f] have *: "(f = 1) = False" "(F = 1) = False" and c: "c ≠ 0" by auto
note res = 2(3)[unfolded simps[of _ f] * if_False Let_def, folded d_def a_def]
note Res = 2(4)[unfolded simps[of _ F] * if_False Let_def, folded D_def A_def]
note IH = 2(2)[folded d_def a_def, OF res Res]
obtain c' where c': "c' = rat_of_int (lead_coeff (gcd F D))" by auto
show ?case
proof (rule IH)
from yun_wrel_minus[OF g yun_wrel_pderiv[OF rel(1)[OF f]]]
have d: "yun_wrel D c d" unfolding D_def d_def .
have a: "yun_rel A c' a" unfolding A_def a_def
by (rule yun_rel_gcd[OF f d c c'])
hence "yun_erel A a" unfolding yun_erel_def by auto
thus "list_all2 (rel_prod yun_erel (=)) ((A, i) # Hs) ((a, i) # hs)"
using hs by auto
have A0: "A ≠ 0" by (rule rel(4)[OF a])
have "A dvd D" "a dvd d" unfolding A_def a_def by auto
from yun_wrel_div[OF d rel(1)[OF a] this A0]
show "yun_wrel (D div A) (c / c') (d div a)" .
have "A dvd F" "a dvd f" unfolding A_def a_def by auto
from yun_rel_div[OF f a this]
show "yun_rel (F div A) (c / c') (f div a)" .
qed
qed
qed
lemma yun_monic_factorization_int_yun_rel: assumes
res: "yun_gcd.yun_monic_factorization gcd f = res"
and Res: "yun_gcd.yun_monic_factorization gcd F = Res"
and f: "yun_rel F c f"
shows "list_all2 (rel_prod yun_erel (=)) Res res"
proof -
note ff = yun_relD[OF f]
let ?g = "gcd f (pderiv f)"
let ?yf = "yun_gcd.yun_factorization_main gcd (f div ?g) (pderiv f div ?g) 0 []"
let ?G = "gcd F (pderiv F)"
let ?yF = "yun_gcd.yun_factorization_main gcd (F div ?G) (pderiv F div ?G) 0 []"
obtain r R where r: "?yf = r" and R: "?yF = R" by blast
from res[unfolded yun_gcd.yun_monic_factorization_def Let_def r]
have res: "res = [(a, i)←r . a ≠ 1]" by simp
from Res[unfolded yun_gcd.yun_monic_factorization_def Let_def R]
have Res: "Res = [(A, i)←R . A ≠ 1]" by simp
from yun_wrel_pderiv[OF ff(1)] have f': "yun_wrel (pderiv F) c (pderiv f)" .
from ff have c: "c ≠ 0" by auto
from yun_rel_gcd[OF f f' c refl] obtain d where g: "yun_rel ?G d ?g" ..
from yun_rel_div[OF f g] have 1: "yun_rel (F div ?G) (c / d) (f div ?g)" by auto
from yun_wrel_div[OF f' yun_relD(1)[OF g] _ _ yun_relD(4)[OF g]]
have 2: "yun_wrel (pderiv F div ?G) (c / d) (pderiv f div ?g)" by auto
from yun_factorization_main_int[OF refl refl ff(6) r R 1 2]
have "list_all2 (rel_prod yun_erel (=)) R r" by simp
thus ?thesis unfolding res Res
by (induct R r rule: list_all2_induct, auto dest: yun_erel_1_eq)
qed
lemma yun_rel_same_right: assumes "yun_rel f c G" "yun_rel g d G"
shows "f = g"
proof -
note f = yun_relD[OF assms(1)]
note g = yun_relD[OF assms(2)]
let ?r = "rat_of_int"
let ?rp = "map_poly ?r"
from g have d: "d ≠ 0" by auto
obtain a b where quot: "quotient_of (c / d) = (a,b)" by force
from quotient_of_nonzero[of "c/d", unfolded quot] have b: "b ≠ 0" by simp
note f(2)
also have "smult c G = smult (c / d) (smult d G)" using d by (auto simp: field_simps)
also have "smult d G = ?rp g" using g(2) by simp
also have cd: "c / d = (?r a / ?r b)" using quotient_of_div[OF quot] .
finally have fg: "?rp f = smult (?r a / ?r b) (?rp g)" by simp
from f have "c ≠ 0" by auto
with cd d have a: "a ≠ 0" by auto
from arg_cong[OF fg, of "λ x. smult (?r b) x"]
have "smult (?r b) (?rp f) = smult (?r a) (?rp g)" using b by auto
hence "?rp (smult b f) = ?rp (smult a g)" by (auto simp: hom_distribs)
then have fg: "[:b:] * f = [:a:] * g" by auto
from arg_cong[OF this, of content, unfolded content_mult f(8) g(8)]
have "content [: b :] = content [: a :]" by simp
hence abs: "abs a = abs b" unfolding content_def using b a by auto
from arg_cong[OF fg, of "λ x. lead_coeff x > 0", unfolded lead_coeff_mult] f(5) g(5) a b
have "(a > 0) = (b > 0)" by (simp add: zero_less_mult_iff)
with a b abs have "a = b" by auto
with arg_cong[OF fg, of "λ x. x div [:b:]"] b show ?thesis
by (metis nonzero_mult_div_cancel_left pCons_eq_0_iff)
qed
definition square_free_factorization_int_main :: "int poly ⇒ (int poly × nat) list" where
"square_free_factorization_int_main f = (case square_free_heuristic f of None ⇒
yun_gcd.yun_monic_factorization gcd f | Some p ⇒ [(f,0)])"
lemma square_free_factorization_int_main: assumes res: "square_free_factorization_int_main f = fs"
and ct: "content f = 1" and lc: "lead_coeff f > 0"
and deg: "degree f ≠ 0"
shows "square_free_factorization f (1,fs) ∧ (∀ fi i. (fi, i) ∈ set fs ⟶ content fi = 1 ∧ lead_coeff fi > 0) ∧
distinct (map snd fs)"
proof (cases "square_free_heuristic f")
case None
from lc have f0: "f ≠ 0" by auto
from res None have fs: "yun_gcd.yun_monic_factorization gcd f = fs"
unfolding square_free_factorization_int_main_def by auto
let ?r = "rat_of_int"
let ?rp = "map_poly ?r"
define G where "G = smult (inverse (lead_coeff (?rp f))) (?rp f)"
have "?rp f ≠ 0" using f0 by auto
hence mon: "monic G" unfolding G_def coeff_smult by simp
obtain Fs where Fs: "yun_gcd.yun_monic_factorization gcd G = Fs" by blast
from lc have lg: "lead_coeff (?rp f) ≠ 0" by auto
let ?c = "lead_coeff (?rp f)"
define c where "c = ?c"
have rp: "?rp f = smult c G" unfolding G_def c_def by (simp add: field_simps)
have in_rel: "yun_rel f c G" unfolding yun_rel_def yun_wrel_def
using rp mon lc ct by auto
from yun_monic_factorization_int_yun_rel[OF Fs fs in_rel]
have out_rel: "list_all2 (rel_prod yun_erel (=)) fs Fs" by auto
from yun_monic_factorization[OF Fs mon]
have "square_free_factorization G (1, Fs)" and dist: "distinct (map snd Fs)" by auto
note sff = square_free_factorizationD[OF this(1)]
from out_rel have "map snd fs = map snd Fs" by (induct fs Fs rule: list_all2_induct, auto)
with dist have dist': "distinct (map snd fs)" by auto
have main: "square_free_factorization f (1, fs) ∧ (∀ fi i. (fi, i) ∈ set fs ⟶ content fi = 1 ∧ lead_coeff fi > 0)"
unfolding square_free_factorization_def split
proof (intro conjI allI impI)
from ct have "f ≠ 0" by auto
thus "f = 0 ⟹ 1 = 0" "f = 0 ⟹ fs = []" by auto
from dist' show "distinct fs" by (simp add: distinct_map)
{
fix a i
assume a: "(a,i) ∈ set fs"
with out_rel obtain bj where "bj ∈ set Fs" and "rel_prod yun_erel (=) (a,i) bj"
unfolding list_all2_conv_all_nth set_conv_nth by fastforce
then obtain b where b: "(b,i) ∈ set Fs" and ab: "yun_erel a b" by (cases bj, auto simp: rel_prod.simps)
from sff(2)[OF b] have b': "square_free b" "degree b ≠ 0" by auto
from ab obtain c where rel: "yun_rel a c b" unfolding yun_erel_def by auto
note aa = yun_relD[OF this]
from aa have c0: "c ≠ 0" by auto
from b' aa(3) show "degree a > 0" by simp
from square_free_smult[OF c0 b'(1), folded aa(2)]
show "square_free a" unfolding square_free_def by (force simp: dvd_def hom_distribs)
show cnt: "content a = 1" and lc: "lead_coeff a > 0" using aa by auto
fix A I
assume A: "(A,I) ∈ set fs" and diff: "(a,i) ≠ (A,I)"
from a[unfolded set_conv_nth] obtain k where k: "fs ! k = (a,i)" "k < length fs" by auto
from A[unfolded set_conv_nth] obtain K where K: "fs ! K = (A,I)" "K < length fs" by auto
from diff k K have kK: "k ≠ K" by auto
from dist'[unfolded distinct_conv_nth length_map, rule_format, OF k(2) K(2) kK]
have iI: "i ≠ I" using k K by simp
from A out_rel obtain Bj where "Bj ∈ set Fs" and "rel_prod yun_erel (=) (A,I) Bj"
unfolding list_all2_conv_all_nth set_conv_nth by fastforce
then obtain B where B: "(B,I) ∈ set Fs" and AB: "yun_erel A B" by (cases Bj, auto simp: rel_prod.simps)
then obtain C where Rel: "yun_rel A C B" unfolding yun_erel_def by auto
note AA = yun_relD[OF this]
from iI have "(b,i) ≠ (B,I)" by auto
from sff(3)[OF b B this] have cop: "coprime b B" by simp
from AA have C: "C ≠ 0" by auto
from yun_rel_gcd[OF rel AA(1) C refl] obtain c where "yun_rel (gcd a A) c (gcd b B)" by auto
note rel = yun_relD[OF this]
from rel(2) cop have "?rp (gcd a A) = [: c :]" by simp
from arg_cong[OF this, of degree] have "degree (gcd a A) = 0" by simp
from degree0_coeffs[OF this] obtain c where gcd: "gcd a A = [: c :]" by auto
from rel(8) rel(5) show "Rings.coprime a A"
by (auto intro!: gcd_eq_1_imp_coprime simp add: gcd)
}
let ?prod = "λ fs. (∏(a, i)∈set fs. a ^ Suc i)"
let ?pr = "λ fs. (∏(a, i)←fs. a ^ Suc i)"
define pr where "pr = ?prod fs"
from ‹distinct fs› have pfs: "?prod fs = ?pr fs" by (rule prod.distinct_set_conv_list)
from ‹distinct Fs› have pFs: "?prod Fs = ?pr Fs" by (rule prod.distinct_set_conv_list)
from out_rel have "yun_erel (?prod fs) (?prod Fs)" unfolding pfs pFs
proof (induct fs Fs rule: list_all2_induct)
case (Cons ai fs Ai Fs)
obtain a i where ai: "ai = (a,i)" by force
from Cons(1) ai obtain A where Ai: "Ai = (A,i)"
and rel: "yun_erel a A" by (cases Ai, auto simp: rel_prod.simps)
show ?case unfolding ai Ai using yun_erel_mult[OF yun_erel_pow[OF rel, of "Suc i"] Cons(3)]
by auto
qed simp
also have "?prod Fs = G" using sff(1) by simp
finally obtain d where rel: "yun_rel pr d G" unfolding yun_erel_def pr_def by auto
with in_rel have "f = pr" by (rule yun_rel_same_right)
thus "f = smult 1 (?prod fs)" unfolding pr_def by simp
qed
from main dist' show ?thesis by auto
next
case (Some p)
from res[unfolded square_free_factorization_int_main_def Some] have fs: "fs = [(f,0)]" by auto
from lc have f0: "f ≠ 0" by auto
from square_free_heuristic[OF Some] poly_mod_prime.separable_impl(1)[of p f] square_free_mod_imp_square_free[of p f] deg
show ?thesis unfolding fs
by (auto simp: ct lc square_free_factorization_def f0 poly_mod_prime_def)
qed
definition square_free_factorization_int' :: "int poly ⇒ int × (int poly × nat)list" where
"square_free_factorization_int' f = (if degree f = 0
then (lead_coeff f,[]) else (let
c = content f;
d = (sgn (lead_coeff f) * c);
g = sdiv_poly f d
in (d, square_free_factorization_int_main g)))"
lemma square_free_factorization_int': assumes res: "square_free_factorization_int' f = (d, fs)"
shows "square_free_factorization f (d,fs)"
"(fi, i) ∈ set fs ⟹ content fi = 1 ∧ lead_coeff fi > 0"
"distinct (map snd fs)"
proof -
note res = res[unfolded square_free_factorization_int'_def Let_def]
have "square_free_factorization f (d,fs)
∧ ((fi, i) ∈ set fs ⟶ content fi = 1 ∧ lead_coeff fi > 0)
∧ distinct (map snd fs)"
proof (cases "degree f = 0")
case True
from degree0_coeffs[OF True] obtain c where f: "f = [: c :]" by auto
thus ?thesis using res by (simp add: square_free_factorization_def)
next
case False
let ?s = "sgn (lead_coeff f)"
have s: "?s ∈ {-1,1}" using False unfolding sgn_if by auto
define g where "g = smult ?s f"
let ?d = "?s * content f"
have "content g = content ([:?s:] * f)" unfolding g_def by simp
also have "… = content [:?s:] * content f" unfolding content_mult by simp
also have "content [:?s:] = 1" using s by (auto simp: content_def)
finally have cg: "content g = content f" by simp
from False res
have d: "d = ?d" and fs: "fs = square_free_factorization_int_main (sdiv_poly f ?d)" by auto
let ?g = "primitive_part g"
define ng where "ng = primitive_part g"
note fs
also have "sdiv_poly f ?d = sdiv_poly g (content g)" unfolding cg unfolding g_def
by (rule poly_eqI, unfold coeff_sdiv_poly coeff_smult, insert s, auto simp: div_minus_right)
finally have fs: "square_free_factorization_int_main ng = fs"
unfolding primitive_part_alt_def ng_def by simp
have "lead_coeff f ≠ 0" using False by auto
hence lg: "lead_coeff g > 0" unfolding g_def lead_coeff_smult
by (meson linorder_neqE_linordered_idom sgn_greater sgn_less zero_less_mult_iff)
hence g0: "g ≠ 0" by auto
from g0 have "content g ≠ 0" by simp
from arg_cong[OF content_times_primitive_part[of g], of lead_coeff, unfolded lead_coeff_smult]
lg content_ge_0_int[of g] have lg': "lead_coeff ng > 0" unfolding ng_def
by (metis ‹content g ≠ 0› dual_order.antisym dual_order.strict_implies_order zero_less_mult_iff)
from content_primitive_part[OF g0] have c_ng: "content ng = 1" unfolding ng_def .
have "degree ng = degree f" using ‹content [:sgn (lead_coeff f):] = 1› g_def ng_def
by (auto simp add: sgn_eq_0_iff)
with False have "degree ng ≠ 0" by auto
note main = square_free_factorization_int_main[OF fs c_ng lg' this]
show ?thesis
proof (intro conjI impI)
{
assume "(fi, i) ∈ set fs"
with main show "content fi = 1" "0 < lead_coeff fi" by auto
}
have d0: "d ≠ 0" using ‹content [:?s:] = 1› d by (auto simp:sgn_eq_0_iff)
have "smult d ng = smult ?s (smult (content g) (primitive_part g))"
unfolding ng_def d cg by simp
also have "smult (content g) (primitive_part g) = g" using content_times_primitive_part .
also have "smult ?s g = f" unfolding g_def using s by auto
finally have id: "smult d ng = f" .
from main have "square_free_factorization ng (1, fs)" by auto
from square_free_factorization_smult[OF d0 this]
show "square_free_factorization f (d,fs)" unfolding id by simp
show "distinct (map snd fs)" using main by auto
qed
qed
thus "square_free_factorization f (d,fs)"
"(fi, i) ∈ set fs ⟹ content fi = 1 ∧ lead_coeff fi > 0" "distinct (map snd fs)" by auto
qed
definition x_split :: "'a :: semiring_0 poly ⇒ nat × 'a poly" where
"x_split f = (let fs = coeffs f; zs = takeWhile ((=) 0) fs
in case zs of [] ⇒ (0,f) | _ ⇒ (length zs, poly_of_list (dropWhile ((=) 0) fs)))"
lemma x_split: assumes "x_split f = (n, g)"
shows "f = monom 1 n * g" "n ≠ 0 ∨ f ≠ 0 ⟹ ¬ monom 1 1 dvd g"
proof -
define zs where "zs = takeWhile ((=) 0) (coeffs f)"
note res = assms[unfolded zs_def[symmetric] x_split_def Let_def]
have "f = monom 1 n * g ∧ ((n ≠ 0 ∨ f ≠ 0) ⟶ ¬ (monom 1 1 dvd g))" (is "_ ∧ (_ ⟶ ¬ (?x dvd _))")
proof (cases "f = 0")
case True
with res have "n = 0" "g = 0" unfolding zs_def by auto
thus ?thesis using True by auto
next
case False note f = this
show ?thesis
proof (cases "zs = []")
case True
hence choice: "coeff f 0 ≠ 0" using f unfolding zs_def coeff_f_0_code poly_compare_0_code
by (cases "coeffs f", auto)
have dvd: "?x dvd h ⟷ coeff h 0 = 0" for h by (simp add: monom_1_dvd_iff')
from True choice res f show ?thesis unfolding dvd by auto
next
case False
define ys where "ys = dropWhile ((=) 0) (coeffs f)"
have dvd: "?x dvd h ⟷ coeff h 0 = 0" for h by (simp add: monom_1_dvd_iff')
from res False have n: "n = length zs" and g: "g = poly_of_list ys" unfolding ys_def
by (cases zs, auto)+
obtain xx where xx: "coeffs f = xx" by auto
have "coeffs f = zs @ ys" unfolding zs_def ys_def by auto
also have "zs = replicate n 0" unfolding zs_def n xx by (induct xx, auto)
finally have ff: "coeffs f = replicate n 0 @ ys" by auto
from f have "lead_coeff f ≠ 0" by auto
then have nz: "coeffs f ≠ []" "last (coeffs f) ≠ 0"
by (simp_all add: last_coeffs_eq_coeff_degree)
have ys: "ys ≠ []" using nz[unfolded ff] by auto
with ys_def have hd: "hd ys ≠ 0" by (metis (full_types) hd_dropWhile)
hence "coeff (poly_of_list ys) 0 ≠ 0" unfolding poly_of_list_def coeff_Poly using ys by (cases ys, auto)
moreover have "coeffs (Poly ys) = ys"
by (simp add: ys_def strip_while_dropWhile_commute)
then have "coeffs (monom_mult n (Poly ys)) = replicate n 0 @ ys"
by (simp add: coeffs_eq_iff monom_mult_def [symmetric] ff ys monom_mult_code)
ultimately show ?thesis unfolding dvd g
by (auto simp add: coeffs_eq_iff monom_mult_def [symmetric] ff)
qed
qed
thus "f = monom 1 n * g" "n ≠ 0 ∨ f ≠ 0 ⟹ ¬ monom 1 1 dvd g" by auto
qed
definition square_free_factorization_int :: "int poly ⇒ int × (int poly × nat)list" where
"square_free_factorization_int f = (case x_split f of (n,g)
⇒ case square_free_factorization_int' g of (d,fs)
⇒ if n = 0 then (d,fs) else (d, (monom 1 1, n - 1) # fs))"
lemma square_free_factorization_int: assumes res: "square_free_factorization_int f = (d, fs)"
shows "square_free_factorization f (d,fs)"
"(fi, i) ∈ set fs ⟹ primitive fi ∧ lead_coeff fi > 0"
proof -
obtain n g where xs: "x_split f = (n,g)" by force
obtain c hs where sf: "square_free_factorization_int' g = (c,hs)" by force
from res[unfolded square_free_factorization_int_def xs sf split]
have d: "d = c" and fs: "fs = (if n = 0 then hs else (monom 1 1, n - 1) # hs)" by (cases n, auto)
note sff = square_free_factorization_int'(1-2)[OF sf]
note xs = x_split[OF xs]
let ?x = "monom 1 1 :: int poly"
have x: "primitive ?x ∧ lead_coeff ?x = 1 ∧ degree ?x = 1"
by (auto simp add: degree_monom_eq content_def monom_Suc)
thus "(fi, i) ∈ set fs ⟹ primitive fi ∧ lead_coeff fi > 0" using sff(2) unfolding fs
by (cases n, auto)
show "square_free_factorization f (d,fs)"
proof (cases n)
case 0
with d fs sff xs show ?thesis by auto
next
case (Suc m)
with xs have fg: "f = monom 1 (Suc m) * g" and dvd: "¬ ?x dvd g" by auto
from Suc have fs: "fs = (?x,m) # hs" unfolding fs by auto
have degx: "degree ?x = 1" by code_simp
from irreducible⇩d_square_free[OF linear_irreducible⇩d[OF this]] have sfx: "square_free ?x" by auto
have fg: "f = ?x ^ n * g" unfolding fg Suc by (metis x_pow_n)
have eq0: "?x ^ n * g = 0 ⟷ g = 0" by simp
note sf = square_free_factorizationD[OF sff(1)]
{
fix a i
assume ai: "(a,i) ∈ set hs"
with sf(4) have g0: "g ≠ 0" by auto
from split_list[OF ai] obtain ys zs where hs: "hs = ys @ (a,i) # zs" by auto
have "a dvd g" unfolding square_free_factorization_prod_list[OF sff(1)] hs
by (rule dvd_smult, simp add: ac_simps)
moreover have "¬ ?x dvd g" using xs[unfolded Suc] by auto
ultimately have dvd: "¬ ?x dvd a" using dvd_trans by blast
from sf(2)[OF ai] have "a ≠ 0" by auto
have "1 = gcd ?x a"
proof (rule gcdI)
fix d
assume d: "d dvd ?x" "d dvd a"
from content_dvd_contentI[OF d(1)] x have cnt: "is_unit (content d)" by auto
show "is_unit d"
proof (cases "degree d = 1")
case False
with divides_degree[OF d(1), unfolded degx] have "degree d = 0" by auto
from degree0_coeffs[OF this] obtain c where dc: "d = [:c:]" by auto
from cnt[unfolded dc] have "is_unit c" by (auto simp: content_def, cases "c = 0", auto)
hence "d * d = 1" unfolding dc by (cases "c = -1"; cases "c = 1", auto)
thus "is_unit d" by (metis dvd_triv_right)
next
case True
from d(1) obtain e where xde: "?x = d * e" unfolding dvd_def by auto
from arg_cong[OF this, of degree] degx have "degree d + degree e = 1"
by (metis True add.right_neutral degree_0 degree_mult_eq one_neq_zero)
with True have "degree e = 0" by auto
from degree0_coeffs[OF this] xde obtain e where xde: "?x = [:e:] * d" by auto
from arg_cong[OF this, of content, unfolded content_mult] x
have "content [:e:] * content d = 1" by auto
also have "content [:e :] = abs e" by (auto simp: content_def, cases "e = 0", auto)
finally have "¦e¦ * content d = 1" .
from pos_zmult_eq_1_iff_lemma[OF this] have "e * e = 1" by (cases "e = 1"; cases "e = -1", auto)
with arg_cong[OF xde, of "smult e"] have "d = ?x * [:e:]" by auto
hence "?x dvd d" unfolding dvd_def by blast
with d(2) have "?x dvd a" by (metis dvd_trans)
with dvd show ?thesis by auto
qed
qed auto
hence "coprime ?x a"
by (simp add: gcd_eq_1_imp_coprime)
note this dvd
} note hs_dvd_x = this
from hs_dvd_x[of ?x m]
have nmem: "(?x,m) ∉ set hs" by auto
hence eq: "?x ^ n * g = smult c (∏(a, i)∈set fs. a ^ Suc i)"
unfolding sf(1) unfolding fs Suc by simp
show ?thesis unfolding fg d unfolding square_free_factorization_def split eq0 unfolding eq
proof (intro conjI allI impI, rule refl)
fix a i
assume ai: "(a,i) ∈ set fs"
thus "square_free a" "degree a > 0" using sf(2) sfx degx unfolding fs by auto
fix b j
assume bj: "(b,j) ∈ set fs" and diff: "(a,i) ≠ (b,j)"
consider (hs_hs) "(a,i) ∈ set hs" "(b,j) ∈ set hs"
| (hs_x) "(a,i) ∈ set hs" "b = ?x"
| (x_hs) "(b,j) ∈ set hs" "a = ?x"
using ai bj diff unfolding fs by auto
then show "Rings.coprime a b"
proof cases
case hs_hs
from sf(3)[OF this diff] show ?thesis .
next
case hs_x
from hs_dvd_x(1)[OF hs_x(1)] show ?thesis unfolding hs_x(2) by (simp add: ac_simps)
next
case x_hs
from hs_dvd_x(1)[OF x_hs(1)] show ?thesis unfolding x_hs(2) by simp
qed
next
show "g = 0 ⟹ c = 0" using sf(4) by auto
show "g = 0 ⟹ fs = []" using sf(4) xs Suc by auto
show "distinct fs" using sf(5) nmem unfolding fs by auto
qed
qed
qed
end
Theory Factorize_Int_Poly
subsection ‹Factoring Arbitrary Integer Polynomials›
text ‹We combine the factorization algorithm for square-free integer polynomials
with a square-free factorization algorithm to
a factorization algorithm for integer polynomials which does not make
any assumptions.›
theory Factorize_Int_Poly
imports
Berlekamp_Zassenhaus
Square_Free_Factorization_Int
begin
hide_const coeff monom
lifting_forget poly.lifting
typedef int_poly_factorization_algorithm = "{alg.
∀ (f :: int poly) fs. square_free f ⟶ degree f > 0 ⟶ alg f = fs ⟶
(f = prod_list fs ∧ (∀ fi ∈ set fs. irreducible⇩d fi))}"
by (rule exI[of _ berlekamp_zassenhaus_factorization],
insert berlekamp_zassenhaus_factorization_irreducible⇩d, auto)
setup_lifting type_definition_int_poly_factorization_algorithm
lift_definition int_poly_factorization_algorithm :: "int_poly_factorization_algorithm ⇒
(int poly ⇒ int poly list)" is "λ x. x" .
lemma int_poly_factorization_algorithm_irreducible⇩d:
assumes "int_poly_factorization_algorithm alg f = fs"
and "square_free f"
and "degree f > 0"
shows "f = prod_list fs ∧ (∀ fi ∈ set fs. irreducible⇩d fi)"
using assms by (transfer, auto)
corollary int_poly_factorization_algorithm_irreducible:
assumes res: "int_poly_factorization_algorithm alg f = fs"
and sf: "square_free f"
and deg: "degree f > 0"
and pr: "primitive f"
shows "f = prod_list fs ∧ (∀ fi ∈ set fs. irreducible fi ∧ degree fi > 0 ∧ primitive fi)"
proof (intro conjI ballI)
note * = int_poly_factorization_algorithm_irreducible⇩d[OF res sf deg]
from * show f: "f = prod_list fs" by auto
fix fi assume fi: "fi ∈ set fs"
with primitive_prod_list[OF pr[unfolded f]] show "primitive fi" by auto
from irreducible_primitive_connect[OF this] * pr[unfolded f] fi
show "irreducible fi" by auto
from * fi show "degree fi > 0" by (auto)
qed
lemma irreducible_imp_square_free:
assumes irr: "irreducible (p::'a::idom poly)" shows "square_free p"
proof(intro square_freeI)
from irr show p0: "p ≠ 0" by auto
fix a assume "a * a dvd p"
then obtain b where paab: "p = a * (a * b)" by (elim dvdE, auto)
assume "degree a > 0"
then have a1: "¬ a dvd 1" by (auto simp: poly_dvd_1)
then have ab1: "¬ a * b dvd 1" using dvd_mult_left by auto
from paab irr a1 ab1 show False by force
qed
lemma not_mem_set_dropWhileD: "x ∉ set (dropWhile P xs) ⟹ x ∈ set xs ⟹ P x"
by (metis dropWhile_append3 in_set_conv_decomp)
lemma primitive_reflect_poly:
fixes f :: "'a :: comm_semiring_1 poly"
shows "primitive (reflect_poly f) = primitive f"
proof-
have "(∀ a ∈ set (coeffs f). x dvd a) ⟷ (∀a ∈ set (dropWhile ((=) 0) (coeffs f)). x dvd a)" for x
by (auto dest: not_mem_set_dropWhileD set_dropWhileD)
then show ?thesis by (auto simp: primitive_def coeffs_reflect_poly)
qed
lemma gcd_list_sub:
assumes "set xs ⊆ set ys" shows "gcd_list ys dvd gcd_list xs"
by (metis Gcd_fin.subset assms semiring_gcd_class.gcd_dvd1)
lemma content_reflect_poly:
"content (reflect_poly f) = content f" (is "?l = ?r")
proof-
have l: "?l = gcd_list (dropWhile ((=) 0) (coeffs f))" (is "_ = gcd_list ?xs")
by (simp add: content_def reflect_poly_def)
have "set ?xs ⊆ set (coeffs f)" by (auto dest: set_dropWhileD)
from gcd_list_sub[OF this]
have "?r dvd gcd_list ?xs" by (simp add: content_def)
with l have rl: "?r dvd ?l" by auto
have "set (coeffs f) ⊆ set (0 # ?xs)" by (auto dest: not_mem_set_dropWhileD)
from gcd_list_sub[OF this]
have "gcd_list ?xs dvd ?r" by (simp add: content_def)
with l have lr: "?l dvd ?r" by auto
from rl lr show "?l = ?r" by (simp add: associated_eqI)
qed
lemma coeff_primitive_part: "content f * coeff (primitive_part f) i = coeff f i"
using arg_cong[OF content_times_primitive_part[of f], of "λf. coeff f _", unfolded coeff_smult].
lemma smult_cancel[simp]:
fixes c :: "'a :: idom"
shows "smult c f = smult c g ⟷ c = 0 ∨ f = g"
proof-
have l: "smult c f = [:c:] * f" by simp
have r: "smult c g = [:c:] * g" by simp
show ?thesis unfolding l r mult_cancel_left by simp
qed
lemma primitive_part_reflect_poly:
fixes f :: "'a :: {semiring_gcd,idom} poly"
shows "primitive_part (reflect_poly f) = reflect_poly (primitive_part f)" (is "?l = ?r")
using content_times_primitive_part[of "reflect_poly f"]
proof-
note content_reflect_poly[of f, symmetric]
also have "smult (content (reflect_poly f)) ?l = reflect_poly f" by simp
also have "... = reflect_poly (smult (content f) (primitive_part f))" by simp
finally show ?thesis unfolding reflect_poly_smult smult_cancel by auto
qed
lemma reflect_poly_eq_zero[simp]:
"reflect_poly f = 0 ⟷ f = 0"
proof
assume "reflect_poly f = 0"
then have "coeff (reflect_poly f) 0 = 0" by simp
then have "lead_coeff f = 0" by simp
then show "f = 0" by simp
qed simp
lemma irreducible⇩d_reflect_poly_main:
fixes f :: "'a :: {idom, semiring_gcd} poly"
assumes nz: "coeff f 0 ≠ 0"
and irr: "irreducible⇩d (reflect_poly f)"
shows "irreducible⇩d f"
proof
let ?r = reflect_poly
from irr degree_reflect_poly_eq[OF nz] show "degree f > 0" by auto
fix g h
assume deg: "degree g < degree f" "degree h < degree f" and fgh: "f = g * h"
from arg_cong[OF fgh, of "λ f. coeff f 0"] nz
have nz': "coeff g 0 ≠ 0" by (auto simp: coeff_mult_0)
note rfgh = arg_cong[OF fgh, of reflect_poly, unfolded reflect_poly_mult[of g h]]
from deg degree_reflect_poly_le[of g] degree_reflect_poly_le[of h] degree_reflect_poly_eq[OF nz]
have "degree (?r h) < degree (?r f)" "degree (?r g) < degree (?r f)" by auto
with irr rfgh show False by auto
qed
lemma irreducible⇩d_reflect_poly:
fixes f :: "'a :: {idom, semiring_gcd} poly"
assumes nz: "coeff f 0 ≠ 0"
shows "irreducible⇩d (reflect_poly f) = irreducible⇩d f"
proof
assume "irreducible⇩d (reflect_poly f)"
from irreducible⇩d_reflect_poly_main[OF nz this] show "irreducible⇩d f" .
next
from nz have nzr: "coeff (reflect_poly f) 0 ≠ 0" by auto
assume "irreducible⇩d f"
with nz have "irreducible⇩d (reflect_poly (reflect_poly f))" by simp
from irreducible⇩d_reflect_poly_main[OF nzr this]
show "irreducible⇩d (reflect_poly f)" .
qed
lemma irreducible_reflect_poly:
fixes f :: "'a :: {idom,semiring_gcd} poly"
assumes nz: "coeff f 0 ≠ 0"
shows "irreducible (reflect_poly f) = irreducible f" (is "?l = ?r")
proof (cases "degree f = 0")
case True then obtain f0 where "f = [:f0:]" by (auto dest: degree0_coeffs)
then show ?thesis by simp
next
case deg: False
show ?thesis
proof (cases "primitive f")
case False
with deg irreducible_imp_primitive[of f] irreducible_imp_primitive[of "reflect_poly f"] nz
show ?thesis unfolding primitive_reflect_poly by auto
next
case cf: True
let ?r = "reflect_poly"
from nz have nz': "coeff (?r f) 0 ≠ 0" by auto
let ?ir = irreducible⇩d
from irreducible⇩d_reflect_poly[OF nz] irreducible⇩d_reflect_poly[OF nz'] nz
have "?ir f ⟷ ?ir (reflect_poly f)" by auto
also have "... ⟷ irreducible (reflect_poly f)"
by (rule irreducible_primitive_connect, unfold primitive_reflect_poly, fact cf)
finally show ?thesis
by (unfold irreducible_primitive_connect[OF cf], auto)
qed
qed
lemma reflect_poly_dvd: "(f :: 'a :: idom poly) dvd g ⟹ reflect_poly f dvd reflect_poly g"
unfolding dvd_def by (auto simp: reflect_poly_mult)
lemma square_free_reflect_poly: fixes f :: "'a :: idom poly"
assumes sf: "square_free f"
and nz: "coeff f 0 ≠ 0"
shows "square_free (reflect_poly f)" unfolding square_free_def
proof (intro allI conjI impI notI)
let ?r = reflect_poly
from sf[unfolded square_free_def]
have f0: "f ≠ 0" and sf: "⋀ q. 0 < degree q ⟹ q * q dvd f ⟹ False" by auto
from f0 nz show "?r f = 0 ⟹ False" by auto
fix q
assume 0: "0 < degree q" and dvd: "q * q dvd ?r f"
from dvd have "q dvd ?r f" by auto
then obtain x where id: "?r f = q * x" by fastforce
{
assume "coeff q 0 = 0"
hence "coeff (?r f) 0 = 0" using id by (auto simp: coeff_mult)
with nz have False by auto
}
hence nzq: "coeff q 0 ≠ 0" by auto
from dvd have "?r (q * q) dvd ?r (?r f)" by (rule reflect_poly_dvd)
also have "?r (?r f) = f" using nz by auto
also have "?r (q * q) = ?r q * ?r q" by (rule reflect_poly_mult)
finally have "?r q * ?r q dvd f" .
from sf[OF _ this] 0 nzq show False by simp
qed
lemma gcd_reflect_poly: fixes f :: "'a :: {factorial_ring_gcd, semiring_gcd_mult_normalize} poly"
assumes nz: "coeff f 0 ≠ 0" "coeff g 0 ≠ 0"
shows "gcd (reflect_poly f) (reflect_poly g) = normalize (reflect_poly (gcd f g))"
proof (rule sym, rule gcdI)
have "gcd f g dvd f" by auto
from reflect_poly_dvd[OF this]
show "normalize (reflect_poly (gcd f g)) dvd reflect_poly f" by simp
have "gcd f g dvd g" by auto
from reflect_poly_dvd[OF this]
show "normalize (reflect_poly (gcd f g)) dvd reflect_poly g" by simp
show "normalize (normalize (reflect_poly (gcd f g))) = normalize (reflect_poly (gcd f g))" by auto
fix h
assume hf: "h dvd reflect_poly f" and hg: "h dvd reflect_poly g"
from hf obtain k where "reflect_poly f = h * k" unfolding dvd_def by auto
from arg_cong[OF this, of "λ f. coeff f 0", unfolded coeff_mult_0] nz(1) have h: "coeff h 0 ≠ 0" by auto
from reflect_poly_dvd[OF hf] reflect_poly_dvd[OF hg]
have "reflect_poly h dvd f" "reflect_poly h dvd g" using nz by auto
hence "reflect_poly h dvd gcd f g" by auto
from reflect_poly_dvd[OF this] h have "h dvd reflect_poly (gcd f g)" by auto
thus "h dvd normalize (reflect_poly (gcd f g))" by auto
qed
lemma linear_primitive_irreducible:
fixes f :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
assumes deg: "degree f = 1" and cf: "primitive f"
shows "irreducible f"
proof (intro irreducibleI)
fix a b assume fab: "f = a * b"
with deg have a0: "a ≠ 0" and b0: "b ≠ 0" by auto
from deg[unfolded fab] degree_mult_eq[OF this] have "degree a = 0 ∨ degree b = 0" by auto
then show "a dvd 1 ∨ b dvd 1"
proof
assume "degree a = 0"
then obtain a0 where a: "a = [:a0:]" by (auto dest:degree0_coeffs)
with fab have "c ∈ set (coeffs f) ⟹ a0 dvd c" for c by (cases "a0 = 0", auto simp: coeffs_smult)
with cf show ?thesis by (auto dest: primitiveD simp: a)
next
assume "degree b = 0"
then obtain b0 where b: "b = [:b0:]" by (auto dest:degree0_coeffs)
with fab have "c ∈ set (coeffs f) ⟹ b0 dvd c" for c by (cases "b0 = 0", auto simp: coeffs_smult)
with cf show ?thesis by (auto dest: primitiveD simp: b)
qed
qed (insert deg, auto simp: poly_dvd_1)
lemma square_free_factorization_last_coeff_nz:
assumes sff: "square_free_factorization f (a, fs)"
and mem: "(fi,i) ∈ set fs"
and nz: "coeff f 0 ≠ 0"
shows "coeff fi 0 ≠ 0"
proof
assume fi: "coeff fi 0 = 0"
note sff_list = square_free_factorization_prod_list[OF sff]
note sff = square_free_factorizationD[OF sff]
from sff_list have "coeff f 0 = a * coeff (∏(a, i)←fs. a ^ Suc i) 0" by simp
with split_list[OF mem] fi have "coeff f 0 = 0"
by (auto simp: coeff_mult)
with nz show False by simp
qed
context
fixes alg :: int_poly_factorization_algorithm
begin
definition main_int_poly_factorization :: "int poly ⇒ int poly list" where
"main_int_poly_factorization f = (let df = degree f
in if df = 1 then [f] else
if abs (coeff f 0) < abs (coeff f df)
then map reflect_poly (int_poly_factorization_algorithm alg (reflect_poly f))
else int_poly_factorization_algorithm alg f)"
definition internal_int_poly_factorization :: "int poly ⇒ int × (int poly × nat) list" where
"internal_int_poly_factorization f = (
case square_free_factorization_int f of
(a,gis) ⇒ (a, [ (h,i) . (g,i) ← gis, h ← main_int_poly_factorization g ])
)"
lemma internal_int_poly_factorization_code[code]: "internal_int_poly_factorization f = (
case square_free_factorization_int f of (a,gis) ⇒
(a, concat (map (λ (g,i). (map (λ f. (f,i)) (main_int_poly_factorization g))) gis)))"
unfolding internal_int_poly_factorization_def by auto
definition factorize_int_last_nz_poly :: "int poly ⇒ int × (int poly × nat) list" where
"factorize_int_last_nz_poly f = (let df = degree f
in if df = 0 then (coeff f 0, []) else if df = 1 then (content f,[(primitive_part f,0)]) else
internal_int_poly_factorization f)"
definition factorize_int_poly_generic :: "int poly ⇒ int × (int poly × nat) list" where
"factorize_int_poly_generic f = (case x_split f of (n,g)
⇒ if g = 0 then (0,[]) else case factorize_int_last_nz_poly g of (a,fs)
⇒ if n = 0 then (a,fs) else (a, (monom 1 1, n - 1) # fs))"
lemma factorize_int_poly_0[simp]: "factorize_int_poly_generic 0 = (0,[])"
unfolding factorize_int_poly_generic_def x_split_def by simp
lemma main_int_poly_factorization:
assumes res: "main_int_poly_factorization f = fs"
and sf: "square_free f"
and df: "degree f > 0"
and nz: "coeff f 0 ≠ 0"
shows "f = prod_list fs ∧ (∀ fi ∈ set fs. irreducible⇩d fi)"
proof (cases "degree f = 1")
case True
with res[unfolded main_int_poly_factorization_def Let_def]
have "fs = [f]" by auto
with True show ?thesis by auto
next
case False
hence *: "(if degree f = 1 then t :: int poly list else e) = e" for t e by auto
note res = res[unfolded main_int_poly_factorization_def Let_def *]
show ?thesis
proof (cases "abs (coeff f 0) < abs (coeff f (degree f))")
case False
with res have "int_poly_factorization_algorithm alg f = fs" by auto
from int_poly_factorization_algorithm_irreducible⇩d[OF this sf df] show ?thesis .
next
case True
let ?f = "reflect_poly f"
from square_free_reflect_poly[OF sf nz] have sf: "square_free ?f" .
from nz df have df: "degree ?f > 0" by simp
from True res obtain gs where fs: "fs = map reflect_poly gs"
and gs: "int_poly_factorization_algorithm alg (reflect_poly f) = gs"
by auto
from int_poly_factorization_algorithm_irreducible⇩d[OF gs sf df]
have id: "reflect_poly ?f = reflect_poly (prod_list gs)" "?f = prod_list gs"
and irr: "⋀ gi. gi ∈ set gs ⟹ irreducible⇩d gi" by auto
from id(1) have f_fs: "f = prod_list fs" unfolding fs using nz
by (simp add: reflect_poly_prod_list)
{
fix fi
assume "fi ∈ set fs"
from this[unfolded fs] obtain gi where gi: "gi ∈ set gs" and fi: "fi = reflect_poly gi" by auto
{
assume "coeff gi 0 = 0"
with id(2) split_list[OF gi] have "coeff ?f 0 = 0"
by (auto simp: coeff_mult)
with nz have False by auto
}
hence nzg: "coeff gi 0 ≠ 0" by auto
from irreducible⇩d_reflect_poly[OF nzg] irr[OF gi] have "irreducible⇩d fi" unfolding fi by simp
}
with f_fs show ?thesis by auto
qed
qed
lemma internal_int_poly_factorization_mem:
assumes f: "coeff f 0 ≠ 0"
and res: "internal_int_poly_factorization f = (c,fs)"
and mem: "(fi,i) ∈ set fs"
shows "irreducible fi" "irreducible⇩d fi" and "primitive fi" and "degree fi ≠ 0"
proof -
obtain a psi where a_psi: "square_free_factorization_int f = (a, psi)"
by force
from square_free_factorization_int[OF this]
have sff: "square_free_factorization f (a, psi)"
and cnt: "⋀ fi i. (fi, i) ∈ set psi ⟹ primitive fi" by blast+
from square_free_factorization_last_coeff_nz[OF sff _ f]
have nz_fi: "⋀ fi i. (fi, i) ∈ set psi ⟹ coeff fi 0 ≠ 0" by auto
note res = res[unfolded internal_int_poly_factorization_def a_psi Let_def split]
obtain fact where fact: "fact = (λ (q,i :: nat). (map (λ f. (f,i)) (main_int_poly_factorization q)))" by auto
from res[unfolded split Let_def]
have c: "c = a" and fs: "fs = concat (map fact psi)"
unfolding fact by auto
note sff' = square_free_factorizationD[OF sff]
from mem[unfolded fs, simplified] obtain d j where psi: "(d,j) ∈ set psi"
and fi: "(fi, i) ∈ set (fact (d,j))" by auto
obtain hs where d: "main_int_poly_factorization d = hs" by force
from fi[unfolded d split fact] have fi: "fi ∈ set hs" by auto
from main_int_poly_factorization[OF d _ _ nz_fi[OF psi]] sff'(2)[OF psi] cnt[OF psi]
have main: "d = prod_list hs" "⋀ fi. fi ∈ set hs ⟹ irreducible⇩d fi" by auto
from main split_list[OF fi] have "content fi dvd content d" by auto
with cnt[OF psi] show cnt: "primitive fi" by simp
from main(2)[OF fi] show irr: "irreducible⇩d fi" .
show "irreducible fi"
using irreducible_primitive_connect[OF cnt] irr by blast
from irr show "degree fi ≠ 0" by auto
qed
lemma internal_int_poly_factorization:
assumes f: "coeff f 0 ≠ 0"
and res: "internal_int_poly_factorization f = (c,fs)"
shows "square_free_factorization f (c,fs)"
proof -
obtain a psi where a_psi: "square_free_factorization_int f = (a, psi)"
by force
from square_free_factorization_int[OF this]
have sff: "square_free_factorization f (a, psi)"
and pr: "⋀ fi i. (fi, i) ∈ set psi ⟹ primitive fi" by blast+
obtain fact where fact: "fact = (λ (q,i :: nat). (map (λ f. (f,i)) (main_int_poly_factorization q)))" by auto
from res[unfolded split Let_def]
have c: "c = a" and fs: "fs = concat (map fact psi)"
unfolding fact internal_int_poly_factorization_def a_psi by auto
note sff' = square_free_factorizationD[OF sff]
show ?thesis unfolding square_free_factorization_def split
proof (intro conjI impI allI)
show "f = 0 ⟹ c = 0" "f = 0 ⟹ fs = []" using sff'(4) unfolding c fs by auto
{
fix a i
assume "(a,i) ∈ set fs"
from irreducible_imp_square_free internal_int_poly_factorization_mem[OF f res this]
show "square_free a" "degree a > 0" by auto
}
from square_free_factorization_last_coeff_nz[OF sff _ f]
have nz: "⋀ fi i. (fi, i) ∈ set psi ⟹ coeff fi 0 ≠ 0" by auto
have eq: "f = smult c (∏(a, i)←fs. a ^ Suc i)" unfolding
prod.distinct_set_conv_list[OF sff'(5)]
sff'(1) c
proof (rule arg_cong[where f = "smult a"], unfold fs, insert sff'(2) nz, induct psi)
case (Cons pi psi)
obtain p i where pi: "pi = (p,i)" by force
obtain gs where gs: "main_int_poly_factorization p = gs" by auto
from Cons(2)[of p i] have p: "square_free p" "degree p > 0" unfolding pi by auto
from Cons(3)[of p i] have nz: "coeff p 0 ≠ 0" unfolding pi by auto
from main_int_poly_factorization[OF gs p nz] have pgs: "p = prod_list gs" by auto
have fact: "fact (p,i) = map (λ g. (g,i)) gs" unfolding fact split gs by auto
have cong: "⋀ x y X Y. x = X ⟹ y = Y ⟹ x * y = X * Y" by auto
show ?case unfolding pi list.simps prod_list.Cons split fact concat.simps prod_list.append
map_append
proof (rule cong)
show "p ^ Suc i = (∏(a, i)←map (λg. (g, i)) gs. a ^ Suc i)" unfolding pgs
by (induct gs, auto simp: ac_simps power_mult_distrib)
show "(∏(a, i)←psi. a ^ Suc i) = (∏(a, i)←concat (map fact psi). a ^ Suc i)"
by (rule Cons(1), insert Cons(2-3), auto)
qed
qed simp
{
fix i j l fi
assume *: "j < length psi" "l < length (fact (psi ! j))" "fact (psi ! j) ! l = (fi, i)"
from * have psi: "psi ! j ∈ set psi" by auto
obtain d k where dk: "psi ! j = (d,k)" by force
with * have psij: "psi ! j = (d,i)" unfolding fact split by auto
from sff'(2)[OF psi[unfolded psij]] have d: "square_free d" "degree d > 0" by auto
from nz[OF psi[unfolded psij]] have d0: "coeff d 0 ≠ 0" .
from * psij fact
have bz: "main_int_poly_factorization d = map fst (fact (psi ! j))" by (auto simp: o_def)
from main_int_poly_factorization[OF bz d d0] pr[OF psi[unfolded dk]]
have dhs: "d = prod_list (map fst (fact (psi ! j)))" by auto
from * have mem: "fi ∈ set (map fst (fact (psi ! j)))"
by (metis fst_conv image_eqI nth_mem set_map)
from mem dhs psij d have "∃ d. fi ∈ set (map fst (fact (psi ! j))) ∧
d = prod_list (map fst (fact (psi ! j))) ∧
psi ! j = (d, i) ∧
square_free d" by blast
} note deconstruct = this
{
fix k K fi i Fi I
assume k: "k < length fs" "K < length fs" and f: "fs ! k = (fi, i)" "fs ! K = (Fi, I)"
and diff: "k ≠ K"
from nth_concat_diff[OF k[unfolded fs] diff, folded fs, unfolded length_map]
obtain j l J L where diff: "(j, l) ≠ (J, L)"
and j: "j < length psi" "J < length psi"
and l: "l < length (map fact psi ! j)" "L < length (map fact psi ! J)"
and fs: "fs ! k = map fact psi ! j ! l" "fs ! K = map fact psi ! J ! L" by blast+
hence psij: "psi ! j ∈ set psi" by auto
from j have id: "map fact psi ! j = fact (psi ! j)" "map fact psi ! J = fact (psi ! J)" by auto
note l = l[unfolded id] note fs = fs[unfolded id]
from j have psi: "psi ! j ∈ set psi" "psi ! J ∈ set psi" by auto
from deconstruct[OF j(1) l(1) fs(1)[unfolded f, symmetric]]
obtain d where mem: "fi ∈ set (map fst (fact (psi ! j)))"
and d: "d = prod_list (map fst (fact (psi ! j)))" "psi ! j = (d, i)" "square_free d" by blast
from deconstruct[OF j(2) l(2) fs(2)[unfolded f, symmetric]]
obtain D where Mem: "Fi ∈ set (map fst (fact (psi ! J)))"
and D: "D = prod_list (map fst (fact (psi ! J)))" "psi ! J = (D, I)" "square_free D" by blast
from pr[OF psij[unfolded d(2)]] have cnt: "primitive d" .
have "coprime fi Fi"
proof (cases "J = j")
case False
from sff'(5) False j have "(d,i) ≠ (D,I)"
unfolding distinct_conv_nth d(2)[symmetric] D(2)[symmetric] by auto
from sff'(3)[OF psi[unfolded d(2) D(2)] this]
have cop: "coprime d D" by auto
from prod_list_dvd[OF mem, folded d(1)] have fid: "fi dvd d" by auto
from prod_list_dvd[OF Mem, folded D(1)] have FiD: "Fi dvd D" by auto
from coprime_divisors[OF fid FiD] cop show ?thesis by simp
next
case True note id = this
from id diff have diff: "l ≠ L" by auto
obtain bz where bz: "bz = map fst (fact (psi ! j))" by auto
from fs[unfolded f] l
have fi: "fi = bz ! l" "Fi = bz ! L"
unfolding id bz by (metis fst_conv nth_map)+
from d[folded bz] have sf: "square_free (prod_list bz)" by auto
from d[folded bz] cnt have cnt: "content (prod_list bz) = 1" by auto
from l have l: "l < length bz" "L < length bz" unfolding bz id by auto
from l fi have "fi ∈ set bz" by auto
from content_dvd_1[OF cnt prod_list_dvd[OF this]] have cnt: "content fi = 1" .
obtain g where g: "g = gcd fi Fi" by auto
have g': "g dvd fi" "g dvd Fi" unfolding g by auto
define bef where "bef = take l bz"
define aft where "aft = drop (Suc l) bz"
from id_take_nth_drop[OF l(1)] l have bz: "bz = bef @ fi # aft" and bef: "length bef = l"
unfolding bef_def aft_def fi by auto
with l diff have mem: "Fi ∈ set (bef @ aft)" unfolding fi(2) by (auto simp: nth_append)
from split_list[OF this] obtain Bef Aft where ba: "bef @ aft = Bef @ Fi # Aft" by auto
have "prod_list bz = fi * prod_list (bef @ aft)" unfolding bz by simp
also have "prod_list (bef @ aft) = Fi * prod_list (Bef @ Aft)" unfolding ba by auto
finally have "fi * Fi dvd prod_list bz" by auto
with g' have "g * g dvd prod_list bz" by (meson dvd_trans mult_dvd_mono)
with sf[unfolded square_free_def] have deg: "degree g = 0" by auto
from content_dvd_1[OF cnt g'(1)] have cnt: "content g = 1" .
from degree0_coeffs[OF deg] obtain c where gc: "g = [: c :]" by auto
from cnt[unfolded gc content_def, simplified] have "abs c = 1"
by (cases "c = 0", auto)
with g gc have "gcd fi Fi ∈ {1,-1}" by fastforce
thus "coprime fi Fi"
by (auto intro!: gcd_eq_1_imp_coprime)
(metis dvd_minus_iff dvd_refl is_unit_gcd_iff one_neq_neg_one)
qed
} note cop = this
show dist: "distinct fs" unfolding distinct_conv_nth
proof (intro impI allI)
fix k K
assume k: "k < length fs" "K < length fs" and diff: "k ≠ K"
obtain fi i Fi I where f: "fs ! k = (fi,i)" "fs ! K = (Fi,I)" by force+
from cop[OF k f diff] have cop: "coprime fi Fi" .
from k(1) f(1) have "(fi,i) ∈ set fs" unfolding set_conv_nth by force
from internal_int_poly_factorization_mem[OF assms(1) res this] have "degree fi > 0" by auto
hence "¬ is_unit fi" by (simp add: poly_dvd_1)
with cop coprime_id_is_unit[of fi] have "fi ≠ Fi" by auto
thus "fs ! k ≠ fs ! K" unfolding f by auto
qed
show "f = smult c (∏(a, i)∈set fs. a ^ Suc i)" unfolding eq
prod.distinct_set_conv_list[OF dist] by simp
fix fi i Fi I
assume mem: "(fi, i) ∈ set fs" "(Fi,I) ∈ set fs" and diff: "(fi, i) ≠ (Fi, I)"
then obtain k K where k: "k < length fs" "K < length fs"
and f: "fs ! k = (fi, i)" "fs ! K = (Fi, I)" unfolding set_conv_nth by auto
with diff have diff: "k ≠ K" by auto
from cop[OF k f diff] show "Rings.coprime fi Fi" by auto
qed
qed
lemma factorize_int_last_nz_poly: assumes res: "factorize_int_last_nz_poly f = (c,fs)"
and nz: "coeff f 0 ≠ 0"
shows "square_free_factorization f (c,fs)"
"(fi,i) ∈ set fs ⟹ irreducible fi"
"(fi,i) ∈ set fs ⟹ degree fi ≠ 0"
proof (atomize(full))
from nz have lz: "lead_coeff f ≠ 0" by auto
note res = res[unfolded factorize_int_last_nz_poly_def Let_def]
consider (0) "degree f = 0"
| (1) "degree f = 1"
| (2) "degree f > 1" by linarith
then show "square_free_factorization f (c,fs) ∧ ((fi,i) ∈ set fs ⟶ irreducible fi) ∧ ((fi,i) ∈ set fs ⟶ degree fi ≠ 0)"
proof cases
case 0
from degree0_coeffs[OF 0] obtain a where f: "f = [:a:]" by auto
from res show ?thesis unfolding square_free_factorization_def f by auto
next
case 1
then have irr: "irreducible (primitive_part f)"
by (auto intro!: linear_primitive_irreducible content_primitive_part)
from irreducible_imp_square_free[OF irr] have sf: "square_free (primitive_part f)" .
from 1 have f0: "f ≠ 0" by auto
from res irr sf f0 show ?thesis unfolding square_free_factorization_def by (auto simp: 1)
next
case 2
with res have "internal_int_poly_factorization f = (c,fs)" by auto
from internal_int_poly_factorization[OF nz this] internal_int_poly_factorization_mem[OF nz this]
show ?thesis by auto
qed
qed
lemma factorize_int_poly: assumes res: "factorize_int_poly_generic f = (c,fs)"
shows "square_free_factorization f (c,fs)"
"(fi,i) ∈ set fs ⟹ irreducible fi"
"(fi,i) ∈ set fs ⟹ degree fi ≠ 0"
proof (atomize(full))
obtain n g where xs: "x_split f = (n,g)" by force
obtain d hs where fact: "factorize_int_last_nz_poly g = (d,hs)" by force
from res[unfolded factorize_int_poly_generic_def xs split fact]
have res: "(if g = 0 then (0, []) else if n = 0 then (d, hs) else (d, (monom 1 1, n - 1) # hs)) = (c, fs)" .
note xs = x_split[OF xs]
show "square_free_factorization f (c,fs) ∧ ((fi,i) ∈ set fs ⟶ irreducible fi) ∧ ((fi,i) ∈ set fs ⟶ degree fi ≠ 0)"
proof (cases "g = 0")
case True
hence "f = 0" "c = 0" "fs = []" using res xs by auto
thus ?thesis unfolding square_free_factorization_def by auto
next
case False
with xs have "¬ monom 1 1 dvd g" by auto
hence "coeff g 0 ≠ 0" by (simp add: monom_1_dvd_iff')
note fact = factorize_int_last_nz_poly[OF fact this]
let ?x = "monom 1 1 :: int poly"
have x: "content ?x = 1 ∧ lead_coeff ?x = 1 ∧ degree ?x = 1"
by (auto simp add: degree_monom_eq monom_Suc content_def)
from res False have res: "(if n = 0 then (d, hs) else (d, (?x, n - 1) # hs)) = (c, fs)" by auto
show ?thesis
proof (cases n)
case 0
with res xs have id: "fs = hs" "c = d" "f = g" by auto
from fact show ?thesis unfolding id by auto
next
case (Suc m)
with res have id: "c = d" "fs = (?x,m) # hs" by auto
from Suc xs have fg: "f = monom 1 (Suc m) * g" and dvd: "¬ ?x dvd g" by auto
from x linear_primitive_irreducible[of ?x] have irr: "irreducible ?x" by auto
from irreducible_imp_square_free[OF this] have sfx: "square_free ?x" .
from irr fact have one: "(fi, i) ∈ set fs ⟶ irreducible fi ∧ degree fi ≠ 0" unfolding id by (auto simp: degree_monom_eq)
have fg: "f = ?x ^ n * g" unfolding fg Suc by (metis x_pow_n)
from x have degx: "degree ?x = 1" by simp
note sf = square_free_factorizationD[OF fact(1)]
{
fix a i
assume ai: "(a,i) ∈ set hs"
with sf(4) have g0: "g ≠ 0" by auto
from split_list[OF ai] obtain ys zs where hs: "hs = ys @ (a,i) # zs" by auto
have "a dvd g" unfolding square_free_factorization_prod_list[OF fact(1)] hs
by (rule dvd_smult, simp add: ac_simps)
moreover have "¬ ?x dvd g" using xs[unfolded Suc] by auto
ultimately have dvd: "¬ ?x dvd a" using dvd_trans by blast
from sf(2)[OF ai] have "a ≠ 0" by auto
have "1 = gcd ?x a"
proof (rule gcdI)
fix d
assume d: "d dvd ?x" "d dvd a"
from content_dvd_contentI[OF d(1)] x have cnt: "is_unit (content d)" by auto
show "is_unit d"
proof (cases "degree d = 1")
case False
with divides_degree[OF d(1), unfolded degx] have "degree d = 0" by auto
from degree0_coeffs[OF this] obtain c where dc: "d = [:c:]" by auto
from cnt[unfolded dc] have "is_unit c" by (auto simp: content_def, cases "c = 0", auto)
hence "d * d = 1" unfolding dc by (auto, cases "c = -1"; cases "c = 1", auto)
thus "is_unit d" by (metis dvd_triv_right)
next
case True
from d(1) obtain e where xde: "?x = d * e" unfolding dvd_def by auto
from arg_cong[OF this, of degree] degx have "degree d + degree e = 1"
by (metis True add.right_neutral degree_0 degree_mult_eq one_neq_zero)
with True have "degree e = 0" by auto
from degree0_coeffs[OF this] xde obtain e where xde: "?x = [:e:] * d" by auto
from arg_cong[OF this, of content, unfolded content_mult] x
have "content [:e:] * content d = 1" by auto
also have "content [:e :] = abs e" by (auto simp: content_def, cases "e = 0", auto)
finally have "¦e¦ * content d = 1" .
from pos_zmult_eq_1_iff_lemma[OF this] have "e * e = 1" by (cases "e = 1"; cases "e = -1", auto)
with arg_cong[OF xde, of "smult e"] have "d = ?x * [:e:]" by auto
hence "?x dvd d" unfolding dvd_def by blast
with d(2) have "?x dvd a" by (metis dvd_trans)
with dvd show ?thesis by auto
qed
qed auto
hence "coprime ?x a"
by (simp add: gcd_eq_1_imp_coprime)
note this dvd
} note hs_dvd_x = this
from hs_dvd_x[of ?x m]
have nmem: "(?x,m) ∉ set hs" by auto
hence eq: "?x ^ n * g = smult d (∏(a, i)∈set fs. a ^ Suc i)"
unfolding sf(1) unfolding id Suc by simp
have eq0: "?x ^ n * g = 0 ⟷ g = 0" by simp
have "square_free_factorization f (d,fs)" unfolding fg id(1) square_free_factorization_def split eq0 unfolding eq
proof (intro conjI allI impI, rule refl)
fix a i
assume ai: "(a,i) ∈ set fs"
thus "square_free a" "degree a > 0" using sf(2) sfx degx unfolding id by auto
fix b j
assume bj: "(b,j) ∈ set fs" and diff: "(a,i) ≠ (b,j)"
consider (hs_hs) "(a,i) ∈ set hs" "(b,j) ∈ set hs"
| (hs_x) "(a,i) ∈ set hs" "b = ?x"
| (x_hs) "(b,j) ∈ set hs" "a = ?x"
using ai bj diff unfolding id by auto
thus "Rings.coprime a b"
proof cases
case hs_hs
from sf(3)[OF this diff] show ?thesis .
next
case hs_x
from hs_dvd_x(1)[OF hs_x(1)] show ?thesis unfolding hs_x(2)
by (simp add: ac_simps)
next
case x_hs
from hs_dvd_x(1)[OF x_hs(1)] show ?thesis unfolding x_hs(2)
by simp
qed
next
show "g = 0 ⟹ d = 0" using sf(4) by auto
show "g = 0 ⟹ fs = []" using sf(4) xs Suc by auto
show "distinct fs" using sf(5) nmem unfolding id by auto
qed
thus ?thesis using one unfolding id by auto
qed
qed
qed
end
lift_definition berlekamp_zassenhaus_factorization_algorithm :: int_poly_factorization_algorithm
is berlekamp_zassenhaus_factorization
using berlekamp_zassenhaus_factorization_irreducible⇩d by blast
abbreviation factorize_int_poly where
"factorize_int_poly ≡ factorize_int_poly_generic berlekamp_zassenhaus_factorization_algorithm"
end
Theory Factorize_Rat_Poly
subsection ‹Factoring Rational Polynomials›
text ‹We combine the factorization algorithm for integer polynomials
with Gauss Lemma to a factorization algorithm for rational polynomials.›
theory Factorize_Rat_Poly
imports
Factorize_Int_Poly
begin
interpretation content_hom: monoid_mult_hom
"content::'a::{factorial_semiring, semiring_gcd, normalization_semidom_multiplicative} poly ⇒ _"
by (unfold_locales, auto simp: content_mult)
lemma prod_dvd_1_imp_all_dvd_1:
assumes "finite X" and "prod f X dvd 1" and "x ∈ X" shows "f x dvd 1"
proof (insert assms, induct rule:finite_induct)
case IH: (insert x' X)
show ?case
proof (cases "x = x'")
case True
with IH show ?thesis using dvd_trans[of "f x'" "f x' * _" 1]
by (metis dvd_triv_left prod.insert)
next
case False
then show ?thesis using IH by (auto intro!: IH(3) dvd_trans[of "prod f X" "_ * prod f X" 1])
qed
qed simp
context
fixes alg :: int_poly_factorization_algorithm
begin
definition factorize_rat_poly_generic :: "rat poly ⇒ rat × (rat poly × nat) list" where
"factorize_rat_poly_generic f = (case rat_to_normalized_int_poly f of
(c,g) ⇒ case factorize_int_poly_generic alg g of (d,fs) ⇒ (c * rat_of_int d,
map (λ (fi,i). (map_poly rat_of_int fi, i)) fs))"
lemma factorize_rat_poly_0[simp]: "factorize_rat_poly_generic 0 = (0,[])"
unfolding factorize_rat_poly_generic_def rat_to_normalized_int_poly_def by simp
lemma factorize_rat_poly:
assumes res: "factorize_rat_poly_generic f = (c,fs)"
shows "square_free_factorization f (c,fs)"
and "(fi,i) ∈ set fs ⟹ irreducible fi"
proof(atomize(full), cases "f=0", goal_cases)
case 1 with res show ?case by (auto simp: square_free_factorization_def)
next
case 2 show ?case
proof (unfold square_free_factorization_def split, intro conjI impI allI)
let ?r = rat_of_int
let ?rp = "map_poly ?r"
obtain d g where ri: "rat_to_normalized_int_poly f = (d,g)" by force
obtain e gs where fi: "factorize_int_poly_generic alg g = (e,gs)" by force
from res[unfolded factorize_rat_poly_generic_def ri fi split]
have c: "c = d * ?r e" and fs: "fs = map (λ (fi,i). (?rp fi, i)) gs" by auto
from factorize_int_poly[OF fi]
have irr: "(fi, i) ∈ set gs ⟹ irreducible fi ∧ content fi = 1" for fi i
using irreducible_imp_primitive[of fi] by auto
note sff = factorize_int_poly(1)[OF fi]
note sff' = square_free_factorizationD[OF sff]
{
fix n f
have "?rp (f ^ n) = (?rp f) ^ n"
by (induct n, auto simp: hom_distribs)
} note exp = this
show dist: "distinct fs" using sff'(5) unfolding fs distinct_map inj_on_def by auto
interpret mh: map_poly_inj_idom_hom rat_of_int..
have "f = smult d (?rp g)" using rat_to_normalized_int_poly[OF ri] by auto
also have "… = smult d (?rp (smult e (∏(a, i)∈set gs. a ^ Suc i)))" using sff'(1) by simp
also have "… = smult c (?rp (∏(a, i)∈set gs. a ^ Suc i))" unfolding c by (simp add: hom_distribs)
also have "?rp (∏(a, i)∈set gs. a ^ Suc i) = (∏(a, i)∈set fs. a ^ Suc i)"
unfolding prod.distinct_set_conv_list[OF sff'(5)] prod.distinct_set_conv_list[OF dist]
unfolding fs
by (insert exp, auto intro!: arg_cong[of _ _ "λx. prod_list (map x gs)"] simp: hom_distribs of_int_poly_hom.hom_prod_list)
finally show f: "f = smult c (∏(a, i)∈set fs. a ^ Suc i)" by auto
{
fix a i
assume ai: "(a,i) ∈ set fs"
from ai obtain A where a: "a = ?rp A" and A: "(A,i) ∈ set gs" unfolding fs by auto
fix b j
assume "(b,j) ∈ set fs" and diff: "(a,i) ≠ (b,j)"
from this(1) obtain B where b: "b = ?rp B" and B: "(B,j) ∈ set gs" unfolding fs by auto
from diff[unfolded a b] have "(A,i) ≠ (B,j)" by auto
from sff'(3)[OF A B this]
show "Rings.coprime a b"
by (auto simp add: coprime_iff_gcd_eq_1 gcd_rat_to_gcd_int a b)
}
{
fix fi i
assume "(fi,i) ∈ set fs"
then obtain gi where fi: "fi = ?rp gi" and gi: "(gi,i) ∈ set gs" unfolding fs by auto
from irr[OF gi] have cf_gi: "primitive gi" by auto
then have "primitive (?rp gi)" by (auto simp: content_field_poly)
note [simp] = irreducible_primitive_connect[OF cf_gi] irreducible_primitive_connect[OF this]
show "irreducible fi"
using irr[OF gi] fi irreducible⇩d_int_rat[of gi,simplified] by auto
then show "degree fi > 0" "square_free fi" unfolding fi
by (auto intro: irreducible_imp_square_free)
}
{
assume "f = 0" with ri have *: "d = 1" "g = 0" unfolding rat_to_normalized_int_poly_def by auto
with sff'(4)[OF *(2)] show "c = 0" "fs = []" unfolding c fs by auto
}
qed
qed
end
abbreviation factorize_rat_poly where
"factorize_rat_poly ≡ factorize_rat_poly_generic berlekamp_zassenhaus_factorization_algorithm"
end